Article

From:
To:
Dmitriy Sinyavskiy
Subject:
Re: Russell Libby's Pipes components
Newsgroup:
embarcadero.public.delphi.non-technical

Re: Russell Libby's Pipes components

I found a much more up-to-date version that what Embarf has one their 
website. Here's the source-code...

unit Pipes; // // Unit : Pipes // Author : rllibby // Date : 01.30.2003 - Original code // // 01.19.2006 - Code overhauled to allow for usage in dll's // when compiled with Delphi 6 and up. // // 04.03.2008 - Second overhaul after finding that memory leaks // in the server thread handling when run under // load. Also found cases where messages were missed // using PeekMessage due to the queue being full. It // seems that the message queue has a 10000 message // limit. // // 04.04.2008 - (1) Better memory handling for messages. // (2) Smart reallocation for overlapped reads // (3) Message chunking is handled, which alleviates // the developer from manually splitting data writes // over the network when the data is > 65K. // (4) Temp file backed streams for multi packet // messages. // (5) Added the ability to throttle down client // based on memory consumption in the write queue. // // 05.30.2008 - Updated the client / server components to allow // the Active (server) and Disconnect (client) calls // to be made while processing an event from the // component. // // 06.05.2008 - Wrapped up the TPipeConsole component, which // handles redirection from console processes. // Also provides a means of synchronous execution // by way of the Execute(...) function. // // 10.20.2008 - Added remote code threading for obtaining the // console handle directly. If this fails, the // code will revert to enumerating the windows // of the console process. Also added priority // setting for the process. // // 12.01.2010 - Fix to "constructor TPipeListenThread.Create()" // where "FPipeServer.FThreadCount.Increment" was being // called before the property was set from the incoming // parameters // // Description : Set of client and server named pipe components for Delphi, as // well a console pipe redirection component. // // Notes: // // TPipeClient // // - The worker thread coordinates events with the component by way of // SendMessage. This means the thread that the component lives on has // to have a message loop. Also, it means that the developer needs // to watch what is done in the TPipeClient events. Do not expect the // following calls to work from within the events: // // - FlushPipeBuffers // - WaitForReply // - Write (works, but no memory throttling) // // The reason these calls do not work is that they are expecting // interaction from the worker thead, which is currently stalled while // waiting on the event handler to finish (and the SendMessage call to // complete). I have coded these routines so that they will NOT deadlock, // but again, don't expect them to ever return success if called from // within one of TPipeClient events. The one exception to this is the // call to Disconnect, which can be called from within an event. If // called from within an event, the component will PostMessage to itself // and will perform the true disconnect when the message is handled. // // TPipeServer // // - The worker threads coordinate events with the component by way of // SendMessage. This means the thread that the component lives on has // to have a message loop. No special restrictions for what is done in // the event handlers. // // TPipeConsole // // - The worker thread coordinates events with the component by way of // SendMessage. This means the thread that the component lives on has // to have a message loop. No special restrictions for what is done in // the event handlers. // interface
// Include units uses   Windows, SysUtils, Classes, Messages;
// Compiler defines
  {$IFDEF VER140} { Borland Delphi 6.0 }      {$DEFINE DELPHI_6_ABOVE}   {$ENDIF}
  {$IFDEF VER150} { Borland Delphi 7.0 }      {$DEFINE DELPHI_6_ABOVE}   {$ENDIF}
  {$IFDEF VER160} { Borland Delphi 8.0 }      {$DEFINE DELPHI_6_ABOVE}   {$ENDIF}
  {$IFDEF VER170} { Borland Delphi 2005 }      {$DEFINE DELPHI_6_ABOVE}   {$ENDIF}
  {$IFDEF VER180} { Borland Delphi 2007 }      {$DEFINE DELPHI_6_ABOVE}   {$ENDIF}
  {$IFDEF VER185} { Borland Delphi 2007 }      {$DEFINE DELPHI_6_ABOVE}   {$ENDIF}
  {$IFDEF VER190} { Borland Delphi 2009 }      {$DEFINE DELPHI_6_ABOVE}   {$ENDIF}
// Resource strings resourcestring   resThreadCtx = 'The notify window and the component window do not exist in the same thread!';   resPipeActive = 'Cannot change property while server is active!';   resPipeConnected = 'Cannot change property when client is connected!';   resBadPipeName = 'Invalid pipe name specified!';   resPipeBaseName = '\\.\pipe\';   resPipeBaseFmtName= '\\%s\pipe\';   resPipeName = 'PipeServer';   resConClass = 'ConsoleWindowClass';   resComSpec = 'ComSpec';
// Min, max and default constants const   MAX_NAME = 256;   MAX_WAIT = 1000;   MAX_BUFFER = Pred(MaxWord);   DEF_SLEEP = 100;   DEF_MEMTHROTTLE = 10240000;
// Pipe mode constants const   PIPE_MODE = PIPE_TYPE_MESSAGE or PIPE_READMODE_MESSAGE or PIPE_WAIT;   PIPE_OPENMODE = PIPE_ACCESS_DUPLEX or FILE_FLAG_OVERLAPPED;   PIPE_INSTANCES = PIPE_UNLIMITED_INSTANCES;
// Pipe handle constants const   STD_PIPE_INPUT = 0;   STD_PIPE_OUTPUT = 1;   STD_PIPE_ERROR = 2;
// Mutliblock message constants const   MB_MAGIC = $4347414D; // MAGC   MB_START = $424D5453; // STMB   MB_END = $424D5445; // ETMB   MB_PREFIX = 'PMM';
// Object instance constants const   INSTANCE_COUNT = 313;
// Pipe window message constants const   WM_PIPEERROR_L = WM_USER + 100;   WM_PIPEERROR_W = WM_USER + 101;   WM_PIPECONNECT = WM_USER + 102;   WM_PIPESEND = WM_USER + 103;   WM_PIPEMESSAGE = WM_USER + 104;   WM_PIPE_CON_OUT = WM_USER + 105;   WM_PIPE_CON_ERR = WM_USER + 106;   WM_PIPEMINMSG = WM_PIPEERROR_L;   WM_PIPEMAXMSG = WM_PIPE_CON_ERR;
// Posted (deferred) window messages const   WM_THREADCTX = WM_USER + 200;   WM_DOSHUTDOWN = WM_USER + 300;
// Thread window message constants const   CM_EXECPROC = $8FFD;   CM_DESTROYWINDOW = $8FFC;
// Pipe exception type type   EPipeException = class(Exception);
// Pipe data type type   HPIPE = THandle;
// Record and class types type
  // Forward declarations   TPipeServer = class;   TPipeClient = class;   TWriteQueue = class;
  // Std handles for console redirection   TPipeStdHandles = Array [STD_PIPE_INPUT..STD_PIPE_ERROR] of THandle;
  // Process window info   PPipeConsoleInfo = ^TPipeConsoleInfo;   TPipeConsoleInfo = packed record      ProcessID: DWORD;      ThreadID: DWORD;      Window: HWND;   end;
  // Data write record   PPipeWrite = ^TPipeWrite;   TPipeWrite = packed record      Buffer: PChar;      Count: Integer;   end;
  // Data write message block   PPipeMsgBlock = ^TPipeMsgBlock;   TPipeMsgBlock = packed record      Size: DWORD;      MagicStart: DWORD;      ControlCode: DWORD;      MagicEnd: DWORD;   end;
  // Data writer list record   PWriteNode = ^TWriteNode;   TWriteNode = packed record      PipeWrite: PPipeWrite;      NextNode: PWriteNode;   end;
  // Server pipe info record   PPipeInfo = ^TPipeInfo;   TPipeInfo = packed record      Pipe: HPIPE;      KillEvent: THandle;      WriteQueue: TWriteQueue;   end;
  // Thread sync info   TSyncInfo = class      FSyncBaseTID: THandle;      FThreadWindow: HWND;      FThreadCount: Integer;   end;
  // Exception frame   PRaiseFrame = ^TRaiseFrame;   TRaiseFrame = record     NextRaise: PRaiseFrame;     ExceptAddr: Pointer;     ExceptObject: TObject;     ExceptionRecord:PExceptionRecord;   end;
  // Window proc   TWndMethod = procedure(var Message: TMessage) of object;
  // Object instance structure   PObjectInstance = ^TObjectInstance;   TObjectInstance = packed record      Code: Byte;      Offset: Integer;      case Integer of         0 : (Next: PObjectInstance);         1 : (Method: TWndMethod);   end;
  // Object instance page block   PInstanceBlock = ^TInstanceBlock;   TInstanceBlock = packed record      Next: PInstanceBlock;      Counter: Word;      Code: Array [1..2] of Byte;      WndProcPtr: Pointer;      Instances: Array [0..INSTANCE_COUNT] of TObjectInstance;   end;
  // Pipe context for error messages   TPipeContext = (pcListener, pcWorker);
  // Pipe Events   TOnConsole = procedure(Sender: TObject; Stream: TStream) of object;   TOnConsoleStop = procedure(Sender: TObject; ExitValue: LongWord) of object;   TOnPipeConnect = procedure(Sender: TObject; Pipe: HPIPE) of object;   TOnPipeDisconnect = procedure(Sender: TObject; Pipe: HPIPE) of object;   TOnPipeMessage = procedure(Sender: TObject; Pipe: HPIPE; Stream: TStream) of object;   TOnPipeSent = procedure(Sender: TObject; Pipe: HPIPE; Size: DWORD) of object;   TOnPipeError = procedure(Sender: TObject; Pipe: HPIPE; PipeContext: TPipeContext; ErrorCode: Integer) of object;
  // TWriteQueue class   TWriteQueue = class(TObject)   private      // Private declarations      FMutex: THandle;      FDataEv: THandle;      FEmptyEv: THandle;      FDataSize: LongWord;      FHead: PWriteNode;      FTail: PWriteNode;      procedure UpdateState;      function NodeSize(Node: PWriteNode): LongWord;   protected      // Protected declarations      procedure Clear;      procedure EnqueueControlPacket(ControlCode: DWORD);      procedure EnqueueMultiPacket(PipeWrite: PPipeWrite);      function GetEmpty: Boolean;      function NewNode(PipeWrite: PPipeWrite): PWriteNode;   public      // Public declarations      constructor Create;      destructor Destroy; override;      procedure Enqueue(PipeWrite: PPipeWrite);      procedure EnqueueEndPacket;      procedure EnqueueStartPacket;      function Dequeue: PPipeWrite;      property DataEvent: THandle read FDataEv;      property DataSize: LongWord read FDataSize;      property Empty: Boolean read GetEmpty;      property EmptyEvent: THandle read FEmptyEv;   end;
  // TThreadSync class   TThreadSync = class   private      // Private declarations      FSyncRaise: TObject;      FMethod: TThreadMethod;      FSyncBaseTID: THandle;   public      // Public declarations      constructor Create;      destructor Destroy; override;      procedure Synchronize(Method: TThreadMethod);      property SyncBaseTID: THandle read FSyncBaseTID;   end;
  // TThreadEx class   TThreadEx = class(TThread)   private      // Private declarations      FSync: TThreadSync;      procedure HandleTerminate;   protected      // Protected declarations      procedure SafeSynchronize(Method: TThreadMethod);      procedure Synchronize(Method: TThreadMethod);      procedure DoTerminate; override;   public      // Public declarations      constructor Create(CreateSuspended: Boolean);      destructor Destroy; override;      procedure Wait;      property Sync: TThreadSync read FSync;   end;
  // TSyncManager class   TSyncManager = class(TObject)   private      // Private declarations      FThreadLock: TRTLCriticalSection;      FList: TList;   protected      // Protected declarations      procedure DoDestroyWindow(Info: TSyncInfo);      procedure FreeSyncInfo(Info: TSyncInfo);      function AllocateWindow: HWND;      function FindSyncInfo(SyncBaseTID: LongWord): TSyncInfo;   public      // Public declarations      class function Instance: TSyncManager;      constructor Create;      destructor Destroy; override;      procedure AddThread(ThreadSync: TThreadSync);      procedure RemoveThread(ThreadSync: TThreadSync);      procedure Synchronize(ThreadSync: TThreadSync);   end;
  // TThreadCounter class   TThreadCounter = class(TObject)   private      // Private declarations      FLock: TRTLCriticalSection;      FEmpty: THandle;      FCount: Integer;   protected      // Protected declarations      function GetCount: Integer;   public      // Public declarations      constructor Create;      destructor Destroy; override;      procedure Increment;      procedure Decrement;      procedure WaitForEmpty;      property Count: Integer read GetCount;   end;
  // TFastMemStream class   TFastMemStream = class(TMemoryStream)   protected      // Protected declarations      function Realloc(var NewCapacity: Longint): Pointer; override;   end;
  // Multipacket message handler   TPipeMultiMsg = class(TObject)   private      // Private declarations      FHandle: THandle;      FStream: TStream;   protected      // Protected declarations      procedure CreateTempBacking;   public      // Public declarations      constructor Create;      destructor Destroy; override;      property Stream: TStream read FStream;   end;
  // TPipeListenThread class   TPipeListenThread = class(TThreadEx)   private      // Private declarations      FNotify: HWND;      FNotifyThread: THandle;      FErrorCode: Integer;      FPipe: HPIPE;      FPipeName: String;      FConnected: Boolean;      FEvents: Array [0..1] of THandle;      FOlapConnect: TOverlapped;      FPipeServer: TPipeServer;      FSA: TSecurityAttributes;   protected      // Protected declarations      function CreateServerPipe: Boolean;      procedure DoWorker;      procedure Execute; override;      function SafeSendMessage(Msg: Cardinal; wParam, lParam: Integer): LRESULT;   public      // Public declarations      constructor Create(PipeServer: TPipeServer; KillEvent: THandle);      destructor Destroy; override;   end;
  // TPipeThread class   TPipeThread = class(TThreadEx)   private      // Private declarations      FServer: Boolean;      FNotify: HWND;      FNotifyThread: THandle;      FPipe: HPIPE;      FErrorCode: Integer;      FCounter: TThreadCounter;      FWrite: DWORD;      FWriteQueue: TWriteQueue;      FPipeWrite: PPipeWrite;      FRcvRead: DWORD;      FPendingRead: Boolean;      FPendingWrite: Boolean;      FMultiMsg: TPipeMultiMsg;      FRcvStream: TFastMemStream;      FRcvBuffer: PChar;      FRcvAlloc: DWORD;      FRcvSize: DWORD;      FEvents: Array [0..3] of THandle;      FOlapRead: TOverlapped;      FOlapWrite: TOverlapped;   protected      // Protected declarations      function QueuedRead: Boolean;      function CompleteRead: Boolean;      function QueuedWrite: Boolean;      function CompleteWrite: Boolean;      procedure DoMessage;      procedure Execute; override;      function SafeSendMessage(Msg: Cardinal; wParam, lParam: Integer): LRESULT;   public      // Public declarations      constructor Create(Server: Boolean; NotifyWindow: HWND; NotifyThread: THandle; WriteQueue: TWriteQueue; Counter: TThreadCounter; Pipe: HPIPE; KillEvent: THandle);      destructor Destroy; override;      property Pipe: HPIPE read FPipe;   end;
  // TPipeServer component class   TPipeServer = class(TComponent)   private      // Private declarations      FBaseThread: THandle;      FHwnd: HWND;      FPipeName: String;      FDeferActive: Boolean;      FActive: Boolean;      FInShutDown: Boolean;      FKillEv: THandle;      FClients: TList;      FThreadCount: TThreadCounter;      FListener: TPipeListenThread;      FSA: TSecurityAttributes;      FOPS: TOnPipeSent;      FOPC: TOnPipeConnect;      FOPD: TOnPipeDisconnect;      FOPM: TOnPipeMessage;      FOPE: TOnPipeError;      procedure DoStartup;      procedure DoShutdown;   protected      // Protected declarations      function AllocPipeInfo(Pipe: HPIPE): PPipeInfo;      function GetClient(Index: Integer): HPIPE;      function GetClientCount: Integer;      function GetClientInfo(Pipe: HPIPE; out PipeInfo: PPipeInfo): Boolean;      procedure WndMethod(var Message: TMessage);      procedure RemoveClient(Pipe: HPIPE);      procedure SetActive(Value: Boolean);      procedure SetPipeName(Value: String);      procedure AddWorkerThread(Pipe: HPIPE);      procedure RemoveWorkerThread(Sender: TObject);      procedure RemoveListenerThread(Sender: TObject);      procedure Loaded; override;   public      // Public declarations      constructor Create(AOwner: TComponent); override;      constructor CreateUnowned;      destructor Destroy; override;      function Broadcast(var Buffer; Count: Integer): Boolean; overload;      function Broadcast(var Prefix; PrefixCount: Integer; var Buffer; Count: Integer): Boolean; overload;      function Disconnect(Pipe: HPIPE): Boolean;      function Write(Pipe: HPIPE; var Prefix; PrefixCount: Integer; var Buffer; Count: Integer): Boolean; overload;      function Write(Pipe: HPIPE; var Buffer; Count: Integer): Boolean; overload;      function SendStream(Pipe: HPIPE; Stream: TStream): Boolean;      property WindowHandle: HWND read FHwnd;      property ClientCount: Integer read GetClientCount;      property Clients[Index: Integer]: HPIPE read GetClient;   published      // Published declarations      property Active: Boolean read FActive write SetActive;      property OnPipeSent: TOnPipeSent read FOPS write FOPS;      property OnPipeConnect: TOnPipeConnect read FOPC write FOPC;      property OnPipeDisconnect: TOnPipeDisconnect read FOPD write FOPD;      property OnPipeMessage: TOnPipeMessage read FOPM write FOPM;      property OnPipeError: TOnPipeError read FOPE write FOPE;      property PipeName: String read FPipeName write SetPipeName;   end;
  // TPipeClient component class   TPipeClient = class(TComponent)   private      // Private declarations      FBaseThread: THandle;      FHwnd: HWND;      FPipe: HPIPE;      FPipeName: String;      FServerName: String;      FDisconnecting:Boolean;      FReply: Boolean;      FThrottle: LongWord;      FWriteQueue: TWriteQueue;      FWorker: TPipeThread;      FKillEv: THandle;      FSA: TSecurityAttributes;      FOPE: TOnPipeError;      FOPD: TOnPipeDisconnect;      FOPM: TOnPipeMessage;      FOPS: TOnPipeSent;   protected      // Protected declarations      function GetConnected: Boolean;      procedure SetPipeName(Value: String);      procedure SetServerName(Value: String);      procedure RemoveWorkerThread(Sender: TObject);      procedure WndMethod(var Message: TMessage);   public      // Public declarations      constructor Create(AOwner: TComponent); override;      constructor CreateUnowned;      destructor Destroy; override;      function Connect(WaitTime: DWORD = NMPWAIT_USE_DEFAULT_WAIT; Start: Boolean = True): Boolean;      function WaitForReply(TimeOut: Cardinal = INFINITE): Boolean;      procedure Disconnect;      procedure FlushPipeBuffers;      function SendStream(Stream: TStream): Boolean;      function Write(var Prefix; PrefixCount: Integer; var Buffer; Count: Integer): Boolean; overload;      function Write(var Buffer; Count: Integer): Boolean; overload;      property Connected: Boolean read GetConnected;      property WindowHandle: HWND read FHwnd;      property Pipe: HPIPE read FPipe;   published      // Published declarations      property MemoryThrottle: LongWord read FThrottle write FThrottle;      property PipeName: String read FPipeName write SetPipeName;      property ServerName: String read FServerName write SetServerName;      property OnPipeDisconnect: TOnPipeDisconnect read FOPD write FOPD;      property OnPipeMessage: TOnPipeMessage read FOPM write FOPM;      property OnPipeSent: TOnPipeSent read FOPS write FOPS;      property OnPipeError: TOnPipeError read FOPE write FOPE;   end;
  // TPipeConsoleThread class   TPipeConsoleThread= class(TThreadEx)   private      // Private declarations      FNotify: HWND;      FStream: TFastMemStream;      FProcess: THandle;      FOutput: THandle;      FError: THandle;      procedure ProcessPipe(Handle: THandle; Msg: UINT);   protected      // Protected declarations      procedure Execute; override;      procedure ProcessPipes;      function SafeSendMessage(Msg: Cardinal; wParam, lParam: Integer): LRESULT;   public      // Public declarations      constructor Create(NotifyWindow: HWND; ProcessHandle, OutputPipe, ErrorPipe: THandle);      destructor Destroy; override;   end;
  // TPipeConsole component class   TPipeConsole = class(TComponent)   private      // Private declarations      FRead: TPipeStdHandles;      FWrite: TPipeStdHandles;      FWorker: TPipeConsoleThread;      FPriority: TThreadPriority;      FPI: TProcessInformation;      FSI: TStartupInfo;      FLastErr: Integer;      FVisible: Boolean;      FStopping: Boolean;      FHwnd: HWND;      FOnStop: TOnConsoleStop;      FOnOutput: TOnConsole;      FOnError: TOnConsole;      FApplication: String;      FCommandLine: String;      procedure ProcessPipe(Handle: THandle; Stream: TStream);      function SynchronousRun(OutputStream, ErrorStream: TStream; Timeout: DWORD): DWORD;   protected      // Protected declarations      function GetConsoleHandle: HWND;      function GetRunning: Boolean;      function GetVisible: Boolean;      function OpenStdPipes: Boolean;      procedure CloseStdPipes;      procedure ForcePriority(Value: TThreadPriority);      procedure RemoveWorkerThread(Sender: TObject);      procedure SetLastErr(Value: Integer);      procedure SetPriority(Value: TThreadPriority);      procedure SetVisible(Value: Boolean);      procedure WndMethod(var Message: TMessage);   public      // Public declarations      constructor Create(AOwner: TComponent); override;      constructor CreateUnowned;      destructor Destroy; override;      function ComSpec: String;      function Execute(Application, CommandLine: String; OutputStream, ErrorStream: TStream; Timeout: DWORD = INFINITE): DWORD;      procedure SendCtrlBreak;      procedure SendCtrlC;      function Start(Application, CommandLine: String): Boolean;      procedure Stop(ExitValue: DWORD);      procedure Write(const Buffer; Length: Integer);      property Application: String read FApplication;      property CommandLine: String read FCommandLine;      property ConsoleHandle: HWND read GetConsoleHandle;      property Running: Boolean read GetRunning;   published      // Published declarations      property LastError: Integer read FLastErr write SetLastErr;      property OnError: TOnConsole read FOnError write FOnError;      property OnOutput: TOnConsole read FOnOutput write FOnOutput;      property OnStop: TOnConsoleStop read FOnStop write FOnStop;      property Priority: TThreadPriority read FPriority write SetPriority;      property Visible: Boolean read GetVisible write SetVisible;   end;
// Console helper functions function ExecConsoleEvent(ProcessHandle: THandle; Event: DWORD): Boolean; procedure ExitProcessEx(ProcessHandle: THandle; ExitCode: DWORD); function GetConsoleWindowEx(ProcessHandle: THandle; ProcessID, ThreadID: DWORD): HWND;
// Pipe helper functions function AllocPipeWrite(const Buffer; Count: Integer): PPipeWrite; function AllocPipeWriteWithPrefix(const Prefix; PrefixCount: Integer; const Buffer; Count: Integer): PPipeWrite; procedure CheckPipeName(Value: String); procedure ClearOverlapped(var Overlapped: TOverlapped; ClearEvent: Boolean = False); procedure CloseHandleClear(var Handle: THandle); function ComputerName: String; procedure DisconnectAndClose(Pipe: HPIPE; IsServer: Boolean = True); procedure DisposePipeWrite(var PipeWrite: PPipeWrite); function EnumConsoleWindows(Window: HWND; lParam: Integer): BOOL; stdcall; procedure FlushMessages; function IsHandle(Handle: THandle): Boolean; procedure RaiseWindowsError;
// Security helper functions procedure InitializeSecurity(var SA: TSecurityAttributes); procedure FinalizeSecurity(var SA: TSecurityAttributes);
// Object instance functions function AllocateHWnd(Method: TWndMethod): HWND; procedure DeallocateHWnd(Wnd: HWND); procedure FreeObjectInstance(ObjectInstance: Pointer); function MakeObjectInstance(Method: TWndMethod): Pointer;
// Registration function procedure Register;
implementation
// Global protected variables var   InstBlockList: PInstanceBlock = nil;   InstFreeList: PObjectInstance = nil;   SyncManager: TSyncManager = nil;   InstCritSect: TRTLCriticalSection;   ThreadWndClass: TWndClass = (                                       style: 0;                                       lpfnWndProc: nil;                                       cbClsExtra: 0;                                       cbWndExtra: 0;                                       hInstance: 0;                                       hIcon: 0;                                       hCursor: 0;                                       hbrBackground: 0;                                       lpszMenuName: nil;                                       lpszClassName: 'ThreadSyncWindow');   ObjWndClass: TWndClass = (                                       style: 0;                                       lpfnWndProc: @DefWindowProc;                                       cbClsExtra: 0;                                       cbWndExtra: 0;                                       hInstance: 0;                                       hIcon: 0;                                       hCursor: 0;                                       hbrBackground: 0;                                       lpszMenuName: nil;                                       lpszClassName: 'ObjWndWindow'                                    );
//// TPipeConsoleThread constructor TPipeConsoleThread.Create(NotifyWindow: HWND; ProcessHandle, OutputPipe, ErrorPipe: THandle); begin
  // Perform inherited create (suspended)   inherited Create(True);
  // Resource protection   try      // Set initial state      FProcess:=0;      FNotify:=NotifyWindow;      FOutput:=OutputPipe;      FError:=ErrorPipe;      FStream:=TFastMemStream.Create;   finally      // Duplicate the process handle      DuplicateHandle(GetCurrentProcess, ProcessHandle, GetCurrentProcess, @FProcess, 0, True, DUPLICATE_SAME_ACCESS);   end;
  // Set thread parameters   FreeOnTerminate:=True;   Priority:=tpLower;
end;
destructor TPipeConsoleThread.Destroy; begin
  // Resource protection   try      // Close the process handle      CloseHandleClear(FProcess);      // Free the memory stream      FStream.Free;   finally      // Perform inherited      inherited Destroy;   end;
end;
procedure TPipeConsoleThread.Execute; var dwExitCode: DWORD; begin
  // Set default return value   ReturnValue:=ERROR_SUCCESS;
  // Keep looping until the process terminates   while True do   begin      // Wait for specified amount of time      case WaitForSingleObject(FProcess, DEF_SLEEP) of         // Object is signaled (process is finished)         WAIT_OBJECT_0 :         begin            // Process the output pipes one last time            ProcessPipes;            // Get the process exit code            if GetExitCodeProcess(FProcess, dwExitCode) then ReturnValue:=dwExitCode;            // Break the loop            break;         end;         // Timeout, check the output pipes for data         WAIT_TIMEOUT : ProcessPipes;      else         // Failure, set return code         ReturnValue:=GetLastError;         // Done processing         break;      end;   end;
end;
procedure TPipeConsoleThread.ProcessPipes; begin
  // Process the output pipe   ProcessPipe(FOutput, WM_PIPE_CON_OUT);
  // Process the error pipe   ProcessPipe(FError, WM_PIPE_CON_ERR);
end;
procedure TPipeConsoleThread.ProcessPipe(Handle: THandle; Msg: UINT); var dwRead: DWORD;      dwSize: DWORD; begin
  // Check the pipe for available data   if PeekNamedPipe(Handle, nil, 0, nil, @dwSize, nil) and (dwSize > 0) then   begin      // Set the stream size      FStream.Size:=dwSize;      // Resource protection      try         // Read from the pipe         if ReadFile(Handle, FStream.Memory^, dwSize, dwRead, nil) then         begin            // Make sure we read the number of bytes specified by size            if not(dwRead = dwSize) then FStream.Size:=dwRead;            // Rewind the stream            FStream.Position:=0;            // Send the message to the component            SafeSendMessage(Msg, 0, Integer(FStream));            // Sleep            Sleep(0);         end;      finally         // Clear the stream         FStream.Clear;      end;   end;
end;
function TPipeConsoleThread.SafeSendMessage(Msg: Cardinal; wParam, lParam: Integer): LRESULT; begin
  // Check window handle   if IsWindow(FNotify) then      // Send the message      result:=SendMessage(FNotify, Msg, wParam, lParam)   else      // Failure      result:=0;
end;
//// TPipeConsole constructor TPipeConsole.Create(AOwner: TComponent); begin
  // Perform inherited create   inherited Create(AOwner);
  // Private declarations   FHwnd:=AllocateHWnd(WndMethod);   FillChar(FRead, SizeOf(FRead), 0);   FillChar(FWrite, SizeOf(FWrite), 0);   FillChar(FPI, SizeOf(FPI), 0);   FillChar(FSI, SizeOf(FSI), 0);   FLastErr:=ERROR_SUCCESS;   FPriority:=tpNormal;   SetLength(FApplication, 0);   SetLength(FCommandLine, 0);   FStopping:=False;   FVisible:=False;   FWorker:=nil;
end;
constructor TPipeConsole.CreateUnowned; begin
  // Perform create with no owner   Create(nil);
end;
destructor TPipeConsole.Destroy; begin
  // Resource protection   try      // Stop the console application      Stop(0);      // Deallocate the window handle      DeallocateHwnd(FHwnd);   finally      // Perform inherited      inherited Destroy;   end;
end;
procedure TPipeConsole.SetLastErr(Value: Integer); begin
  // Resource protection   try      // Set the last error for the thread      SetLastError(Value);   finally      // Update the last error status      FLastErr:=Value;   end;
end;
function TPipeConsole.ComSpec: String; begin
  // Allocate buffer for result   SetLength(result, MAX_PATH);
  // Resource protection   try      // Get the environment variable for COMSPEC and truncate to actual result      SetLength(result, GetEnvironmentVariable(PChar(resComSpec), Pointer(result), MAX_PATH));   finally      // Capture the last error code      FLastErr:=GetLastError;   end;
end;
function TPipeConsole.OpenStdPipes: Boolean; var dwIndex: Integer; begin
  // Set default result   result:=False;
  // Resource protection   try      // Close any open handles      CloseStdPipes;      // Resource protection      try         // Iterate the pipe array and create new read / write pipe handles         for dwIndex:=STD_PIPE_INPUT to STD_PIPE_ERROR do         begin            // Create the pipes            if CreatePipe(FRead[dwIndex], FWrite[dwIndex], nil, MAX_BUFFER) then            begin               // Duplicate the read handles so they can be inherited               if DuplicateHandle(GetCurrentProcess, FRead[dwIndex], GetCurrentProcess, @FRead[dwIndex], 0, True, DUPLICATE_CLOSE_SOURCE or DUPLICATE_SAME_ACCESS) then                  // Duplicate the write handles so they can be inherited                  result:=DuplicateHandle(GetCurrentProcess, FWrite[dwIndex], GetCurrentProcess, @FWrite[dwIndex], 0, True, DUPLICATE_CLOSE_SOURCE or DUPLICATE_SAME_ACCESS)               else                  // Failed to duplicate                  result:=False;            end            else               // Failed to create pipes               result:=False;            // Should we continue?            if not(result) then break;         end;      finally         // Capture the last error code         FLastErr:=GetLastError;      end;   finally      // Close all handles on failure      if not(result) then CloseStdPipes;   end;
end;
procedure TPipeConsole.CloseStdPipes; var dwIndex: Integer; begin
  // Iterate the pipe array and close the read / write pipe handles   for dwIndex:=STD_PIPE_INPUT to STD_PIPE_ERROR do   begin      // Close and clear the read handle      CloseHandleClear(FRead[dwIndex]);      // Close and clear the read handle      CloseHandleClear(FWrite[dwIndex]);   end;
end;
function TPipeConsole.GetRunning: Boolean; begin
  // Check process information   result:=(IsHandle(FPI.hProcess) and (WaitForSingleObject(FPI.hProcess, 0) = WAIT_TIMEOUT));
end;
procedure TPipeConsole.SendCtrlBreak; begin
  // Make sure the process is running, then inject and exec   if GetRunning then ExecConsoleEvent(FPI.hProcess, CTRL_BREAK_EVENT);
end;
procedure TPipeConsole.SendCtrlC; begin
  // Make sure the process is running, then inject and exec   if GetRunning then ExecConsoleEvent(FPI.hProcess, CTRL_C_EVENT);
end;
procedure TPipeConsole.Write(const Buffer; Length: Integer); var dwWrite: DWORD; begin
  // Check state   if GetRunning and IsHandle(FWrite[STD_PIPE_INPUT]) then   begin      // Write data to the pipe      WriteFile(FWrite[STD_PIPE_INPUT], Buffer, Length, dwWrite, nil);   end;
end;
function TPipeConsole.GetConsoleHandle: HWND; var lpConInfo: TPipeConsoleInfo; begin
  // Clear the return handle   result:=0;
  // Check to see if running   if GetRunning then   begin      // Clear the window handle      lpConInfo.Window:=0;      // Resource protection      try         // Set process info         lpConInfo.ProcessID:=FPI.dwProcessID;         lpConInfo.ThreadID:=FPI.dwThreadID;         // Enumerate the windows on the console thread         EnumWindows(@EnumConsoleWindows, Integer(@lpConInfo));      finally         // Return the window handle         result:=lpConInfo.Window;      end;   end;
end;
function TPipeConsole.GetVisible: Boolean; var hwndCon: HWND; begin
  // Check running state   if not(GetRunning) then      // If not running then return the stored state      result:=FVisible   else   begin      // Attempt to get the window handle      hwndCon:=GetConsoleWindowEx(FPI.hProcess, FPI.dwProcessId, FPI.dwThreadId);      // Check result      if IsWindow(hwndCon) then         // Return visible state         result:=IsWindowVisible(hwndCon)      else         // Return stored state         result:=FVisible;   end;
end;
procedure TPipeConsole.ForcePriority(Value: TThreadPriority); const Priorities: Array [TThreadPriority] of Integer =                           (                              THREAD_PRIORITY_IDLE,                              THREAD_PRIORITY_LOWEST,                              THREAD_PRIORITY_BELOW_NORMAL,                              THREAD_PRIORITY_NORMAL,                              THREAD_PRIORITY_ABOVE_NORMAL,                              THREAD_PRIORITY_HIGHEST,                              THREAD_PRIORITY_TIME_CRITICAL                           ); begin
  // Check running state   if not(GetRunning) then      // Update the value      FPriority:=Value   else   begin      // Get the thread handle      if SetThreadPriority(FPI.hThread, Priorities[Value]) then      begin         // Priority was set, persist value         FPriority:=Value;      end;   end;
end;
procedure TPipeConsole.SetPriority(Value: TThreadPriority); begin
  // Check against current value   if (FPriority <> Value) then ForcePriority(Value);
end;
procedure TPipeConsole.SetVisible(Value: Boolean); var hwndCon: HWND; begin
  // Check against current state   if not(GetVisible = Value) then   begin      // Update the state      FVisible:=Value;      // Check to see if running      if GetRunning then      begin         // Attempt to have the console window return us its handle         hwndCon:=GetConsoleWindowEx(FPI.hProcess, FPI.dwProcessId, FPI.dwThreadId);         // Check result         if IsWindow(hwndCon) then         begin            // Show or hide based on visibility            if FVisible then               // Show               ShowWindow(hwndCon, SW_SHOWNORMAL)            else               // Hide               ShowWindow(hwndCon, SW_HIDE);         end;      end;   end;
end;
procedure TPipeConsole.WndMethod(var Message: TMessage); begin
  // Handle the pipe messages   case Message.Msg of      // Pipe output from console      WM_PIPE_CON_OUT : if Assigned(FOnOutput) then FOnOutput(Self, TStream(Pointer(Message.lParam)));      // Pipe error from console      WM_PIPE_CON_ERR : if Assigned(FOnError) then FOnError(Self, TStream(Pointer(Message.lParam)));      // Shutdown      WM_DOSHUTDOWN : Stop(Message.WParam);   else      // Call default window procedure      Message.Result:=DefWindowProc(FHwnd, Message.Msg, Message.wParam, Message.lParam);   end;
end;
procedure TPipeConsole.RemoveWorkerThread(Sender: TObject); var dwReturn: LongWord; begin
  // Get the thread return value   dwReturn:=FWorker.ReturnValue;
  // Resource protection   try      // Set thread variable to nil      FWorker:=nil;      // Resource protection      try         // Notify of process stop         if (not(csDestroying in ComponentState) and Assigned(FOnStop)) then FOnStop(Self, dwReturn);      finally         // Close the process and thread handles         CloseHandleClear(FPI.hProcess);         CloseHandleClear(FPI.hThread);      end;   finally      // Close the pipe handles      CloseStdPipes;   end;
end;
procedure TPipeConsole.ProcessPipe(Handle: THandle; Stream: TStream); var lpszBuffer: PChar;      dwRead: DWORD;      dwSize: DWORD; begin
  // Check the pipe for available data   if PeekNamedPipe(Handle, nil, 0, nil, @dwSize, nil) and (dwSize > 0) then   begin      // Allocate buffer for read. Note, we need to clear the output even if no stream is passed      lpszBuffer:=AllocMem(dwSize);      // Resource protection      try         // Read from the pipe         if ReadFile(Handle, lpszBuffer^, dwSize, dwRead, nil) and Assigned(Stream) then         begin            // Save buffer to stream            Stream.Write(lpszBuffer^, dwRead);         end;      finally         // Free the memory         FreeMem(lpszBuffer);      end;   end;
end;
function TPipeConsole.SynchronousRun(OutputStream, ErrorStream: TStream; Timeout: DWORD): DWORD; begin
  // Set default return value   SetLastErr(ERROR_SUCCESS);
  // Resource protection   try      // Keep looping until the process terminates      while True do      begin         // Wait for specified amount of time         case WaitForSingleObject(FPI.hProcess, DEF_SLEEP) of            // Object is signaled (process is finished)            WAIT_OBJECT_0 :            begin               // Process the output pipes one last time               ProcessPipe(FRead[STD_PIPE_OUTPUT], OutputStream);               ProcessPipe(FRead[STD_PIPE_ERROR], ErrorStream);               // Break the loop               break;            end;            // Timeout, check the output pipes for data            WAIT_TIMEOUT :            begin               // Process the output pipes               ProcessPipe(FRead[STD_PIPE_OUTPUT], OutputStream);               ProcessPipe(FRead[STD_PIPE_ERROR], ErrorStream);            end;         else            // Failure, set return code            SetLastErr(GetLastError);            // Done processing            break;         end;         // Check the timeout         if (Timeout > 0) and (GetTickCount > Timeout) then         begin            // Terminate the process            ExitProcessEx(FPI.hProcess, 0);            // Set result            SetLastErr(ERROR_TIMEOUT);            // Done processing            break;         end;      end;   finally      // Return last error result      result:=FLastErr;   end;
end;
function TPipeConsole.Execute(Application, CommandLine: String; OutputStream, ErrorStream: TStream; Timeout: DWORD = INFINITE): DWORD; begin
  // Set default result   SetLastErr(ERROR_SUCCESS);
  // Both params cannot be null   if (Length(Application) = 0) and (Length(CommandLine) = 0) then   begin      // Set error code      SetLastErr(ERROR_INVALID_PARAMETER);      // Failure      result:=FLastErr;   end   else   begin      // Stop existing process if running      Stop(0);      // Resource protection      try         // Clear the process information         FillChar(FPI, SizeOf(FPI), 0);         // Clear the startup info structure         FillChar(FSI, SizeOf(FSI), 0);         // Attempt to open the pipes for redirection         if OpenStdPipes then         begin            // Resource protection            try               // Set structure size               FSI.cb:=SizeOf(FSI);               // Set flags               FSI.dwFlags:=STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;               // Determine if the process will be shown or hidden               if FVisible then                  // Show flag                  FSI.wShowWindow:=SW_SHOWNORMAL               else                  // Hide flag                  FSI.wShowWindow:=SW_HIDE;               // Set the redirect handles               FSI.hStdInput:=FRead[STD_PIPE_INPUT];               FSI.hStdOutput:=FWrite[STD_PIPE_OUTPUT];               FSI.hStdError:=FWrite[STD_PIPE_ERROR];               // Create the process               if CreateProcess(Pointer(Application), Pointer(CommandLine), nil, nil, True, CREATE_NEW_CONSOLE or CREATE_NEW_PROCESS_GROUP or NORMAL_PRIORITY_CLASS, nil, nil, FSI, FPI) then               begin                  // Resource protection                  try                     // Set the priority                     if (FPriority <> tpNormal) then ForcePriority(FPriority);                     // Wait for input idle                     WaitForInputIdle(FPI.hProcess, INFINITE);                     // Check timeout value                     if (Timeout = INFINITE) then                        // Synchronous loop with no timeout                        SynchronousRun(OutputStream, ErrorStream, 0)                     else                        // Synchronous loop with timeout                        SynchronousRun(OutputStream, ErrorStream, GetTickCount + Timeout)                  finally                     // Close the process and thread handle                     CloseHandleClear(FPI.hProcess);                     CloseHandleClear(FPI.hThread);                  end;               end               else                  // Set the last error                  SetLastErr(GetLastError);            finally               // Close the pipe handles               CloseStdPipes;            end;         end;      finally         // Return last error code         result:=FLastErr;      end;   end;
end;
function TPipeConsole.Start(Application, CommandLine: String): Boolean; begin
  // Both params cannot be null   if (Length(Application) = 0) and (Length(CommandLine) = 0) then   begin      // Set error code      SetLastErr(ERROR_INVALID_PARAMETER);      // Failure      result:=False;   end   else   begin      // Stop existing process if running      Stop(0);      // Resource protection      try         // Clear the process information         FillChar(FPI, SizeOf(FPI), 0);         // Clear the startup info structure         FillChar(FSI, SizeOf(FSI), 0);         // Attempt to open the pipes for redirection         if OpenStdPipes then         begin            // Set structure size            FSI.cb:=SizeOf(FSI);            // Set flags            FSI.dwFlags:=STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;            // Determine if the process will be shown or hidden            if FVisible then               // Show flag               FSI.wShowWindow:=SW_SHOWNORMAL            else               // Hide flag               FSI.wShowWindow:=SW_HIDE;            // Set the redirect handles            FSI.hStdInput:=FRead[STD_PIPE_INPUT];            FSI.hStdOutput:=FWrite[STD_PIPE_OUTPUT];            FSI.hStdError:=FWrite[STD_PIPE_ERROR];            // Create the process            if CreateProcess(Pointer(Application), Pointer(CommandLine), nil, nil, True, CREATE_NEW_CONSOLE or CREATE_NEW_PROCESS_GROUP or NORMAL_PRIORITY_CLASS, nil, nil, FSI, FPI) then            begin               // Persist the strings used to start the process               FApplication:=Application;               FCommandLine:=CommandLine;               // Set the priority               if (FPriority <> tpNormal) then ForcePriority(FPriority);               // Wait for input idle               WaitForInputIdle(FPI.hProcess, INFINITE);               // Exception trap               try                  // Process is created, now start the worker thread                  FWorker:=TPipeConsoleThread.Create(FHwnd, FPI.hProcess, FRead[STD_PIPE_OUTPUT], FRead[STD_PIPE_ERROR]);                  // Resource protection                  try                     // Set the OnTerminate handler                     FWorker.OnTerminate:=RemoveWorkerThread;                  finally                     // Resume the worker thread                     FWorker.Resume;                  end;               except                  // Stop the process                  Stop(0);               end;            end            else               // Get the last error               SetLastErr(GetLastError);         end;      finally         // Check final running state         result:=Assigned(FWorker);      end;   end;
end;
procedure TPipeConsole.Stop(ExitValue: DWORD); begin
  // Check to see if still running   if GetRunning and not(FStopping) then   begin      // Check to see if in a send message      if InSendMessage then         // Defered shutdown         PostMessage(FHwnd, WM_DOSHUTDOWN, ExitValue, 0)      else      begin         // Set state         FStopping:=True;         // Resource protection         try            // Clear strings            SetLength(FApplication, 0);            SetLength(FCommandLine, 0);            // Resource protection            try               // Force the process to close               ExitProcessEx(FPI.hProcess, ExitValue);               // Wait for thread to finish up               if Assigned(FWorker) then FWorker.Wait;            finally               // Close the process and thread handle               CloseHandleClear(FPI.hProcess);               CloseHandleClear(FPI.hThread);               // Close the pipe handles               CloseStdPipes;            end;         finally            // Reset the stopping flag            FStopping:=False;         end;      end;   end;
end;
//// TPipeClient constructor TPipeClient.Create(AOwner: TComponent); begin
  // Perform inherited   inherited Create(AOwner);
  // Set defaults   InitializeSecurity(FSA);   FKillEv:=CreateEvent(@FSA, True, False, nil);   FPipe:=INVALID_HANDLE_VALUE;   FDisconnecting:=False;   FBaseThread:=GetCurrentThreadID;   FThrottle:=DEF_MEMTHROTTLE;   FWriteQueue:=TWriteQueue.Create;   FWorker:=nil;   FPipeName:=resPipeName;   FServerName:=EmptyStr;   FHwnd:=AllocateHWnd(WndMethod);
end;
constructor TPipeClient.CreateUnowned; begin
  // Perform create with no owner   Create(nil);
end;
destructor TPipeClient.Destroy; begin
  // Resource protection   try      // Disconnect the pipe      Disconnect;      // Close the event handle      CloseHandle(FKillEv);      // Free the write queue      FWriteQueue.Free;      // Free memory resources      FinalizeSecurity(FSA);      // Deallocate the window handle      DeAllocateHWnd(FHwnd);   finally      // Perform inherited      inherited Destroy;   end;
end;
function TPipeClient.GetConnected: Boolean; var dwExit: DWORD; begin
  // Check worker thread   if Assigned(FWorker) then      // Check exit state      result:=GetExitCodeThread(FWorker.Handle, dwExit) and (dwExit = STILL_ACTIVE)   else      // Not connected      result:=False;
end;
function TPipeClient.Connect(WaitTime: DWORD = NMPWAIT_USE_DEFAULT_WAIT; Start: Boolean = True): Boolean; var szName: String;      dwMode: DWORD; begin
  // Resource protection   try      // Check current connected state      if not(GetConnected) then      begin         // Check existing pipe handle         if IsHandle(FPipe) then         begin            // Check Start mode            if Start then            begin               // Pipe was already created, start worker thread against it               try                  // Create thread to handle the pipe IO                  FWorker:=TPipeThread.Create(False, FHwnd, FBaseThread, FWriteQueue, nil, FPipe, FKillEv);                  // Resource protection                  try                     // Set the OnTerminate handler                     FWorker.OnTerminate:=RemoveWorkerThread;                  finally;                     // Resume the thread                     FWorker.Resume;                  end;               except                  // Free the worker thread                  FreeAndNil(FWorker);                  // Close the pipe handle                  CloseHandleClear(FPipe);               end;            end;         end         else         begin            // Check name against local computer name first            if (Length(FServerName) = 0) or (CompareText(ComputerName, FServerName) = 0) then               // Set base local pipe name               szName:=resPipeBaseName + FPipeName            else               // Set base pipe name using specified server               szName:=Format(resPipeBaseFmtName, [FServerName]) + FPipeName;            // Attempt to wait for the pipe first            if WaitNamedPipe(PChar(szName), WaitTime) then            begin               // Attempt to create client side handle               FPipe:=CreateFile(PChar(szName), GENERIC_READ or GENERIC_WRITE, 0, @FSA, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED, 0);               // Success if we have a valid handle               if IsHandle(FPipe) then               begin                  // Set the pipe read mode flags                  dwMode:=PIPE_READMODE_MESSAGE or PIPE_WAIT;                  // Update the pipe                  SetNamedPipeHandleState(FPipe, dwMode, nil, nil);                  // Check Start mode                  if Start then                  begin                     // Resource protection                     try                        // Create thread to handle the pipe IO                        FWorker:=TPipeThread.Create(False, FHwnd, FBaseThread, FWriteQueue, nil, FPipe, FKillEv);                        // Resource protection                        try                           // Set the OnTerminate handler                           FWorker.OnTerminate:=RemoveWorkerThread;                        finally;                           // Resume the thread                           FWorker.Resume;                        end;                     except                        // Free the worker thread                        FreeAndNil(FWorker);                        // Close the pipe handle                        CloseHandleClear(FPipe);                     end;                  end;               end;            end;         end;      end;   finally      // Check connected state, or valid handle      result:=GetConnected or IsHandle(FPipe);   end;
end;
procedure TPipeClient.Disconnect; begin
  // Check connected state   if (GetConnected and not(FDisconnecting)) then   begin      // Check to see if processing a message from another thread      if InSendMessage then         // Defered shutdown         PostMessage(FHwnd, WM_DOSHUTDOWN, 0, 0)      else      begin         // Set disconnecting flag         FDisconnecting:=True;         // Resource protection         try            // Resource protection            try               // Check worker thread               if Assigned(FWorker) then               begin                  // Resource protection                  try                     // Signal the kill event for the thread                     SetEvent(FKillEv);                  finally                     // Wait for the thread to complete                     FWorker.Wait;                  end;               end;            finally               // Clear pipe handle               FPipe:=INVALID_HANDLE_VALUE;            end;         finally            // Toggle flag            FDisconnecting:=False;         end;      end;   end   // Check pipe handle   else if IsHandle(FPipe) then      // Close handle      CloseHandleClear(FPipe);
end;
procedure TPipeClient.FlushPipeBuffers; var hEvent: THandle; begin
  // Make sure we are not being called from one of the events   if not(InSendMessage) then   begin      // Get the event handle for the empty state      hEvent:=FWriteQueue.EmptyEvent;      // While the worker thread is running      while GetConnected do      begin         // Wait until the empty flag is set or we get a message         case MsgWaitForMultipleObjects(1, hEvent, False, INFINITE, QS_SENDMESSAGE) of            // Empty event is signalled            WAIT_OBJECT_0 : break;            // Messages waiting to be read            WAIT_OBJECT_0 + 1 : FlushMessages;         end;      end;   end;
end;
function TPipeClient.WaitForReply(TimeOut: Cardinal = INFINITE): Boolean; var lpMsg: TMsg;      dwMark: LongWord; begin
  // Clear reply flag   FReply:=False;
  // Resource protection   try      // Make sure we are not being called from one of the events      if not(InSendMessage) then      begin         // Get current tick count         dwMark:=GetTickCount;         // Check connected state         while not(FReply) and GetConnected do         begin            // Check for timeout            if not(TimeOut = INFINITE) and ((GetTickCount - dwMark) >= TimeOut) then break;            // Peek message from the queue            if PeekMessage(lpMsg, 0, WM_PIPEMINMSG, WM_PIPEMAXMSG, PM_REMOVE) then            begin               // Translate the message               TranslateMessage(lpMsg);               // Dispatch the message               DispatchMessage(lpMsg);            end;         end;      end;   finally      // Is the reply flag set      result:=FReply;   end;
end;
function TPipeClient.SendStream(Stream: TStream): Boolean; var lpszBuffer: PChar;      dwRead: Integer; begin
  // Check stream and current state   if Assigned(Stream) and GetConnected then   begin      // Set default result      result:=True;      // Resource protection      try         // Enqueue the start packet         FWriteQueue.EnqueueStartPacket;         // Resource protection         try            // Allocate buffer for sending            lpszBuffer:=AllocMem(MAX_BUFFER);            // Resource protection            try               // Set stream position               Stream.Position:=0;               // Queue the first read               dwRead:=Stream.Read(lpszBuffer^, MAX_BUFFER);               // While data               while (dwRead > 0) and result do               begin                  // Write the data                  if Write(lpszBuffer^, dwRead) then                     // Seed next data                     dwRead:=Stream.Read(lpszBuffer^, MAX_BUFFER)                  else                     // Failed to write the data                     result:=False;               end;            finally               // Free memory               FreeMem(lpszBuffer);            end;         finally            // Enqueue the end packet            FWriteQueue.EnqueueEndPacket;         end;      finally         // Flush the buffers         FlushPipeBuffers;      end;   end   else      // Invalid param or state      result:=False;
end;
function TPipeClient.Write(var Prefix; PrefixCount: Integer; var Buffer; Count: Integer): Boolean; begin
  // Check for memory throttling   if ((FThrottle > 0) and (FWriteQueue.DataSize > FThrottle) and GetConnected) then FlushPipeBuffers;
  // Check connected state   if GetConnected then   begin      // Resource protection      try         // Queue the data         FWriteQueue.Enqueue(AllocPipeWriteWithPrefix(Prefix, PrefixCount, Buffer, Count));      finally         // Success         result:=True;      end;   end   else      // Not connected      result:=False;
end;
function TPipeClient.Write(var Buffer; Count: Integer): Boolean; begin
  // Check for memory throttling   if ((FThrottle > 0) and (FWriteQueue.DataSize > FThrottle) and GetConnected) then FlushPipeBuffers;
  // Check connected state   if GetConnected then   begin      // Resource protection      try         // Queue the data         FWriteQueue.Enqueue(AllocPipeWrite(Buffer, Count));      finally         // Success         result:=True;      end;   end   else      // Not connected      result:=False;
end;
procedure TPipeClient.SetPipeName(Value: String); begin
  // Check connected state and pipe handle   if GetConnected or IsHandle(FPipe) then      // Raise exception      raise EPipeException.CreateRes(@resPipeConnected)   else   begin      // Check the pipe name      CheckPipeName(Value);      // Set the pipe name      FPipeName:=Value;   end;
end;
procedure TPipeClient.SetServerName(Value: String); begin
  // Check connected state and pipe handle   if GetConnected or IsHandle(FPipe) then      // Raise exception      raise EPipeException.CreateRes(@resPipeConnected)   else      // Set the server name      FServerName:=Value;
end;
procedure TPipeClient.RemoveWorkerThread(Sender: TObject); begin
  // Set thread variable to nil   FWorker:=nil;
  // Resource protection   try      // Notify of disconnect      if (not(csDestroying in ComponentState) and Assigned(FOPD)) then FOPD(Self, FPipe);      // Clear the write queue      FWriteQueue.Clear;   finally      // Invalidate handle      FPipe:=INVALID_HANDLE_VALUE;   end;
end;
procedure TPipeClient.WndMethod(var Message: TMessage); begin
  // Handle the pipe messages   case Message.Msg of      // Pipe worker error      WM_PIPEERROR_W : if Assigned(FOPE) then FOPE(Self, Message.wParam, pcWorker, Message.lParam);      // Pipe data sent      WM_PIPESEND : if Assigned(FOPS) then FOPS(Self, Message.wParam, Message.lParam);      // Pipe data read      WM_PIPEMESSAGE :      begin         // Set reply flag         FReply:=True;         // Fire event         if Assigned(FOPM) then FOPM(Self, Message.wParam, TStream(Pointer(Message.lParam)));      end;      // Raise exception      WM_THREADCTX : raise EPipeException.CreateRes(@resThreadCtx);      // Disconect      WM_DOSHUTDOWN : Disconnect;   else      // Call default window procedure      Message.Result:=DefWindowProc(FHwnd, Message.Msg, Message.wParam, Message.lParam);   end;
end;
//// TPipeServer constructor TPipeServer.Create(AOwner: TComponent); begin
  // Perform inherited   inherited Create(AOwner);
  // Initialize the security attributes   InitializeSecurity(FSA);
  // Set staring defaults   FHwnd:=AllocateHWnd(WndMethod);   FBaseThread:=GetCurrentThreadID;   FPipeName:=resPipeName;   FActive:=False;   FDeferActive:=False;   FInShutDown:=False;   FKillEv:=CreateEvent(@FSA, True, False, nil);   FClients:=TList.Create;   FThreadCount:=TThreadCounter.Create;   FListener:=nil;
end;
constructor TPipeServer.CreateUnowned; begin
  // Perform inherited create with no owner   Create(nil);
end;
destructor TPipeServer.Destroy; begin
  // Resource protection   try      // Perform the shutdown if active      Active:=False;      // Close the event handle      CloseHandle(FKillEv);      // Free the clients list      FClients.Free;      // Free the thread counter      FThreadCount.Free;      // Cleanup memory      FinalizeSecurity(FSA);      // Deallocate the window      DeAllocateHWnd(FHwnd);   finally      // Perform inherited      inherited Destroy;   end;
end;
procedure TPipeServer.WndMethod(var Message: TMessage); begin
  // Handle the pipe messages   case Message.Msg of      // Listener thread error      WM_PIPEERROR_L : if Assigned(FOPE) then FOPE(Self, Message.wParam, pcListener, Message.lParam);      // Worker thread error      WM_PIPEERROR_W : if Assigned(FOPE) then FOPE(Self, Message.wParam, pcWorker, Message.lParam);      // Pipe connected      WM_PIPECONNECT : if Assigned(FOPC) then FOPC(Self, Message.wParam);      // Data message sent on pipe      WM_PIPESEND : if Assigned(FOPS) then FOPS(Self, Message.wParam, Message.lParam);      // Data message recieved on pipe      WM_PIPEMESSAGE : if Assigned(FOPM) then FOPM(Self, Message.wParam, TStream(Pointer(Message.lParam)));      // Raise exception      WM_THREADCTX : raise EPipeException.CreateRes(@resThreadCtx);      // Disconect      WM_DOSHUTDOWN : Active:=False;   else      // Call default window procedure      Message.Result:=DefWindowProc(FHwnd, Message.Msg, Message.wParam, Message.lParam);   end;
end;
function TPipeServer.GetClientInfo(Pipe: HPIPE; out PipeInfo: PPipeInfo): Boolean; var dwIndex: Integer; begin
  // Clear outbound param   PipeInfo:=nil;
  // Resource protection   try      // Locate the pipe info record for the given pipe first      for dwIndex:=Pred(FClients.Count) downto 0 do      begin         // Check pipe info pointer         if (PPipeInfo(FClients[dwIndex])^.Pipe = Pipe) then         begin            // Found the record            PipeInfo:=PPipeInfo(FClients[dwIndex]);            // Done processing            break;         end;      end;   finally      // Success if we have the record      result:=Assigned(PipeInfo);   end;
end;
function TPipeServer.GetClient(Index: Integer): HPIPE; begin
  // Return the requested pipe   result:=PPipeInfo(FClients[Index])^.Pipe;
end;
function TPipeServer.GetClientCount: Integer; begin
  // Return the number of client pipes   result:=FClients.Count;
end;
function TPipeServer.Broadcast(var Buffer; Count: Integer): Boolean; var dwIndex: Integer;      dwCount: Integer; begin
  // Set count   dwCount:=0;
  // Resource protection   try      // Iterate the pipes and write the data to each one      for dwIndex:=Pred(FClients.Count) downto 0 do      begin         // Fail if a write fails         if Write(Clients[dwIndex], Buffer, Count) then            // Update count            Inc(dwCount)         else            // Failed, break out            break;      end;   finally      // Success if all pipes got the message      result:=(dwCount = FClients.Count);   end;
end;
function TPipeServer.Broadcast(var Prefix; PrefixCount: Integer; var Buffer; Count: Integer): Boolean; var dwIndex: Integer;      dwCount: Integer; begin
  // Set count   dwCount:=0;
  // Resource protection   try      // Iterate the pipes and write the data to each one      for dwIndex:=Pred(FClients.Count) downto 0 do      begin         // Fail if a write fails         if Write(Clients[dwIndex], Prefix, PrefixCount, Buffer, Count) then            // Update count            Inc(dwCount)         else            // Failed, break out            break;      end;   finally      // Success if all pipes got the message      result:=(dwCount = FClients.Count);   end;
end;
function TPipeServer.Write(Pipe: HPIPE; var Prefix; PrefixCount: Integer; var Buffer; Count: Integer): Boolean; var ppiClient: PPipeInfo; begin
  // Get the pipe info   if GetClientInfo(Pipe, ppiClient) then   begin      // Queue the data      ppiClient.WriteQueue.Enqueue(AllocPipeWriteWithPrefix(Prefix, PrefixCount, Buffer, Count));      // Success      result:=True;   end   else      // No client info      result:=False;
end;
function TPipeServer.Write(Pipe: HPIPE; var Buffer; Count: Integer): Boolean; var ppiClient: PPipeInfo; begin
  // Get the pipe info   if GetClientInfo(Pipe, ppiClient) then   begin      // Queue the data      ppiClient.WriteQueue.Enqueue(AllocPipeWrite(Buffer, Count));      // Success      result:=True;   end   else      // No client info      result:=False;
end;
function TPipeServer.SendStream(Pipe: HPIPE; Stream: TStream): Boolean; var ppiClient: PPipeInfo;      lpszBuffer: PChar;      dwRead: Integer; begin
  // Check stream and current state   if Assigned(Stream) and GetClientInfo(Pipe, ppiClient) then   begin      // Resource protection      try         // Enqueue the start packet         ppiClient^.WriteQueue.EnqueueStartPacket;         // Resource protection         try            // Allocate buffer for sending            lpszBuffer:=AllocMem(MAX_BUFFER);            // Resource protection            try               // Set stream position               Stream.Position:=0;               // Queue the first read               dwRead:=Stream.Read(lpszBuffer^, MAX_BUFFER);               // While data               while (dwRead > 0) do               begin                  // Enqueue the data                  ppiClient^.WriteQueue.Enqueue(AllocPipeWrite(lpszBuffer^, dwRead));                  // Seed next data                  dwRead:=Stream.Read(lpszBuffer^, MAX_BUFFER)               end;            finally               // Free memory               FreeMem(lpszBuffer);            end;         finally            // Enqueue the end packet            ppiClient^.WriteQueue.EnqueueEndPacket;         end;      finally         // Set default result         result:=True;      end;   end   else      // Invalid param or state      result:=False;
end;
procedure TPipeServer.RemoveClient(Pipe: HPIPE); var ppiClient: PPipeInfo; begin
  // Attempt to get the pipe info   if GetClientInfo(Pipe, ppiClient) then   begin      // Remove from the client list      FClients.Remove(ppiClient);      // Resource protection      try         // Resource protection         try            // Free the write queue            ppiClient^.WriteQueue.Free;            // Close the event handle            CloseHandle(ppiClient^.KillEvent);         finally            // Free the client record            FreeMem(ppiClient);         end;      finally         // Call the OnDisconnect if assigned and not destroying         if not(csDestroying in ComponentState) and Assigned(FOPD) then FOPD(Self, Pipe);      end;   end;
end;
function TPipeServer.Disconnect(Pipe: HPIPE): Boolean; var ppiClient: PPipeInfo;      dwIndex: Integer; begin
  // Set default result   result:=True;
  // Check pipe passed in   if (Pipe = 0) then   begin      // Disconnect all      for dwIndex:=Pred(FClients.Count) downto 0 do      begin         // Signal the kill event         SetEvent(PPipeInfo(FClients[dwIndex])^.KillEvent);      end;   end   // Get the specifed pipe info   else if GetClientInfo(Pipe, ppiClient) then      // Set the kill event      SetEvent(ppiClient^.KillEvent)   else      // Failed to locate the pipe      result:=False;
end;
procedure TPipeServer.Loaded; begin
  // Perform inherited   inherited;
  // Set deferred active state   SetActive(FDeferActive);
end;
procedure TPipeServer.SetActive(Value: Boolean); begin
  // Check against current state   if not(FActive = Value) then   begin      // Check loaded state      if (csLoading in ComponentState) then         // Set deferred state         FDeferActive:=Value      // Check designing state. The problem is that in the IDE, a count on the      // handle will be left open and cause us issues with client connections when      // running in debugger.      else if (csDesigning in ComponentState) then         // Just update the value         FActive:=Value      else if (Value) then         // Perform startup         DoStartup      else         // Perform shutdown         DoShutdown;   end;
end;
procedure TPipeServer.SetPipeName(Value: String); begin
  // Check for change   if not(Value = FPipeName) then   begin      // Check active state      if FActive then         // Cannot change pipe name if pipe server is active         raise EPipeException.CreateRes(@resPipeActive)      else      begin         // Check the pipe name         CheckPipeName(Value);         // Set the new pipe name         FPipeName:=Value;      end;   end;
end;
function TPipeServer.AllocPipeInfo(Pipe: HPIPE): PPipeInfo; begin
  // Create a new pipe info structure to manage the pipe   result:=AllocMem(SizeOf(TPipeInfo));
  // Resource protection   try      // Set the pipe value      result^.Pipe:=Pipe;      // Create the write queue      result^.WriteQueue:=TWriteQueue.Create;      // Create individual kill events      result^.KillEvent:=CreateEvent(nil, True, False, nil);   finally      // Add to client list      FClients.Add(result);   end;
end;
procedure TPipeServer.AddWorkerThread(Pipe: HPIPE); var pstWorker: TPipeThread;      ppInfo: PPipeInfo; begin
  // Set worker thread   pstWorker:=nil;
  // Create a new pipe info structure to manage the pipe   ppInfo:=AllocPipeInfo(Pipe);
  // Resource protection   try      // Create the server worker thread      pstWorker:=TPipeThread.Create(True, FHwnd, FBaseThread, ppInfo^.WriteQueue, FThreadCount, Pipe, ppInfo^.KillEvent);      // Resource protection      try         // Set the OnTerminate handler         pstWorker.OnTerminate:=RemoveWorkerThread;      finally         // Resume the thread         pstWorker.Resume;      end;   except      // Exception during thread create, remove the client record      RemoveClient(Pipe);      // Disconnect and close the pipe handle      DisconnectAndClose(Pipe);      // Free the worker thread object      FreeAndNil(pstWorker);   end;
end;
procedure TPipeServer.RemoveWorkerThread(Sender: TObject); begin
  // Remove the pipe info record associated with this thread   RemoveClient(TPipeThread(Sender).Pipe);
end;
procedure TPipeServer.RemoveListenerThread(Sender: TObject); begin
  // Nil the thread var   FListener:=nil;
  // If we are not in a shutdown and are the only thread, then change the active state   if (not(FInShutDown) and (FThreadCount.Count = 1)) then FActive:=False;
end;
procedure TPipeServer.DoStartup; begin
  // Check active state   if not(FActive) then   begin      // Make sure the kill event is in a non-signaled state      ResetEvent(FKillEv);      // Resource protection      try         // Create the listener thread         FListener:=TPipeListenThread.Create(Self, FKillEv);         // Resource protection         try            // Set the OnTerminate handler            FListener.OnTerminate:=RemoveListenerThread;         finally            // Resume            FListener.Resume;         end;      except         // Free the listener thread         FreeAndNil(FListener);         // Re-raise the exception         raise;      end;      // Set active state      FActive:=True;   end;
end;
procedure TPipeServer.DoShutdown; begin
  // If we are not active then exit   if FActive and not(FInShutDown) then   begin      // Check in message flag      if InSendMessage then         // Defered shutdown         PostMessage(FHwnd, WM_DOSHUTDOWN, 0, 0)      else      begin         // Set shutdown flag         FInShutDown:=True;         // Resource protection         try            // Resource protection            try               // Signal the kill event for the listener thread               SetEvent(FKillEv);               // Disconnect all               Disconnect(0);               // Wait until threads have finished up               FThreadCount.WaitForEmpty;            finally               // Reset active state               FActive:=False;            end;         finally            // Set active state to false            FInShutDown:=False;         end;      end;   end;
end;
//// TPipeThread constructor TPipeThread.Create(Server: Boolean; NotifyWindow: HWND; NotifyThread: THandle; WriteQueue: TWriteQueue; Counter: TThreadCounter; Pipe: HPIPE; KillEvent: THandle); begin
  // Perform inherited create (suspended)   inherited Create(True);
  // Increment the thread counter if assigned   if Assigned(FCounter) then FCounter.Increment;
  // Set initial state   FServer:=Server;   FNotify:=NotifyWindow;   FNotifyThread:=NotifyThread;   FWriteQueue:=WriteQueue;   FCounter:=Counter;   FPipe:=Pipe;   FErrorCode:=ERROR_SUCCESS;   FPendingRead:=False;   FPendingWrite:=False;   FPipeWrite:=nil;   FMultiMsg:=nil;   FRcvSize:=MAX_BUFFER;   FRcvAlloc:=MAX_BUFFER;   FRcvBuffer:=AllocMem(FRcvAlloc);   FRcvStream:=TFastMemStream.Create;   ClearOverlapped(FOlapRead, True);   ClearOverlapped(FOlapWrite, True);   FOlapRead.hEvent:=CreateEvent(nil, True, False, nil);   FOlapWrite.hEvent:=CreateEvent(nil, True, False, nil);   ResetEvent(KillEvent);   FEvents[0]:=KillEvent;   FEvents[1]:=FOlapRead.hEvent;   FEvents[2]:=FOlapWrite.hEvent;   FEvents[3]:=FWriteQueue.DataEvent;
  // Set thread parameters   FreeOnTerminate:=True;   Priority:=tpLower;
end;
destructor TPipeThread.Destroy; begin
  // Resource protection   try      // Resource protection      try         // Free the write buffer we may be holding on to         DisposePipeWrite(FPipeWrite);         // Free the receiver stream         FRcvStream.Free;         // Free buffer memory         FreeMem(FRcvBuffer);      finally         // Decrement the thread counter if assigned         if Assigned(FCounter) then FCounter.Decrement;      end;   finally      // Perform inherited      inherited Destroy;   end;
end;
function TPipeThread.SafeSendMessage(Msg: Cardinal; wParam, lParam: Integer): LRESULT; begin
  // Check notification window   if IsWindow(FNotify) then      // Send the message      result:=SendMessage(FNotify, Msg, wParam, lParam)   else      // Failure      result:=0;
end;
function TPipeThread.QueuedRead: Boolean; begin
  // Resource protection   try      // If we already have a pending read then nothing to do      if not(FPendingRead) then      begin         // Set buffer size         FRcvSize:=FRcvAlloc;         // Keep reading all available data until we get a pending read or a failure         while not(FPendingRead) do         begin            // Set overlapped fields            ClearOverlapped(FOlapRead);            // Perform a read            if ReadFile(FPipe, FRcvBuffer^, FRcvSize, FRcvRead, @FOlapRead) then            begin               // Resource protection               try                  // We read a full message                  FRcvStream.Write(FRcvBuffer^, FRcvRead);                  // Call the OnData                  DoMessage;               finally                  // Reset the read event                  ResetEvent(FOlapRead.hEvent);               end;            end            else            begin               // Get the last error code               FErrorCode:=GetLastError;               // Handle cases where message is larger than read buffer used               if (FErrorCode = ERROR_MORE_DATA) then               begin                  // Write the current data                  FRcvStream.Write(FRcvBuffer^, FRcvSize);                  // Determine how much we need to expand the buffer to                  if PeekNamedPipe(FPipe, nil, 0, nil, nil, @FRcvSize) then                  begin                     // Determine if required size is larger than allocated size                     if (FRcvSize > FRcvAlloc) then                     begin                        // Realloc buffer                        ReallocMem(FRcvBuffer, FRcvSize);                        // Update allocated size                        FRcvAlloc:=FRcvSize;                     end;                  end                  else                  begin                     // Failure                     FErrorCode:=GetLastError;                     // Done                     break;                  end;               end               // Pending read               else if (FErrorCode = ERROR_IO_PENDING) then                  // Set pending flag                  FPendingRead:=True               else                  // Failure                  break;            end;         end;      end;   finally      // Success if we have a pending read      result:=FPendingRead;   end;
end;
function TPipeThread.CompleteRead: Boolean; begin
  // Reset the read event and pending flag   ResetEvent(FOlapRead.hEvent);
  // Reset pending read   FPendingRead:=False;
  // Check the overlapped results   result:=GetOverlappedResult(FPipe, FOlapRead, FRcvRead, True);
  // Handle failure   if not(result) then   begin      // Get the last error code      FErrorCode:=GetLastError;      // Check for more data      if (FErrorCode = ERROR_MORE_DATA) then      begin         // Write the current data to the stream         FRcvStream.Write(FRcvBuffer^, FRcvSize);         // Determine how much we need to expand the buffer to         result:=PeekNamedPipe(FPipe, nil, 0, nil, nil, @FRcvSize);         // Check result         if result then         begin            // Determine if required size is larger than allocated size            if (FRcvSize > FRcvAlloc) then            begin               // Realloc buffer               ReallocMem(FRcvBuffer, FRcvSize);               // Update allocated size               FRcvAlloc:=FRcvSize;            end;            // Set overlapped fields            ClearOverlapped(FOlapRead);            // Read from the file again            result:=ReadFile(FPipe, FRcvBuffer^, FRcvSize, FRcvRead, @FOlapRead);            // Handle error            if not(result) then            begin               // Set error code               FErrorCode:=GetLastError;               // Check for pending again, which means our state hasn't changed               if (FErrorCode = ERROR_IO_PENDING) then               begin                  // Still a pending read                  FPendingRead:=True;                  // Success                  result:=True;               end;            end;         end         else            // Set error code            FErrorCode:=GetLastError;      end;   end;
  // Check result and pending read flag   if result and not(FPendingRead) then   begin      // We have the full message      FRcvStream.Write(FRcvBuffer^, FRcvRead);      // Call the OnData      DoMessage;   end;
end;
function TPipeThread.QueuedWrite: Boolean; var bWrite: Boolean; begin
  // Set default result   result:=True;
  // Check pending state   if not(FPendingWrite) then   begin      // Check state of data event      if (WaitForSingleObject(FEvents[3], 0) = WAIT_OBJECT_0) then      begin         // Dequeue write block         FPipeWrite:=FWriteQueue.Dequeue;         // Is the record assigned?         if Assigned(FPipeWrite) then         begin            // Set overlapped fields            ClearOverlapped(FOlapWrite);            // Write the data to the client            bWrite:=WriteFile(FPipe, FPipeWrite^.Buffer^, FPipeWrite^.Count, FWrite, @FOlapWrite);            // Get the last error code            FErrorCode:=GetLastError;            // Check the write operation            if bWrite then            begin               // Resource protection               try                  // Flush the pipe                  FlushFileBuffers(FPipe);                  // Call the OnData in the main thread                  SafeSendMessage(WM_PIPESEND, FPipe, FWrite);                  // Free the pipe write data                  DisposePipeWrite(FPipeWrite);               finally                  // Reset the write event                  ResetEvent(FOlapWrite.hEvent);               end;            end            // Only acceptable error is pending            else if (FErrorCode = ERROR_IO_PENDING) then               // Set pending flag               FPendingWrite:=True            else               // Failure               result:=False;         end;      end      else         // No data to write         result:=True;   end;
end;
function TPipeThread.CompleteWrite: Boolean; begin
  // Reset the write event and pending flag   ResetEvent(FOlapWrite.hEvent);
  // Resource protection   try      // Check the overlapped results      result:=GetOverlappedResult(FPipe, FOlapWrite, FWrite, True);      // Resource protection      try         // Handle failure         if not(result) then            // Get the last error code            FErrorCode:=GetLastError         else         begin            // Flush the pipe            FlushFileBuffers(FPipe);            // We sent a full message so call the OnSent in the main thread            SafeSendMessage(WM_PIPESEND, FPipe, FWrite);         end;      finally         // Make sure to free the queued pipe data         DisposePipeWrite(FPipeWrite);      end;   finally      // Reset pending flag      FPendingWrite:=False;   end;
end;
procedure TPipeThread.DoMessage; var lpControlMsg: PPipeMsgBlock; begin
  // Rewind the stream   FRcvStream.Position:=0;
  // Resource protection   try      // Check the data to see if this is a multi part message      if (FRcvStream.Size = SizeOf(TPipeMsgBlock)) then      begin         // Cast memory as control message         lpControlMsg:=PPipeMsgBlock(FRcvStream.Memory);         // Check constants         if (lpControlMsg^.Size = SizeOf(TPipeMsgBlock)) and (lpControlMsg^.MagicStart = MB_MAGIC) and (lpControlMsg^.MagicEnd = MB_MAGIC) then         begin            // Check to see if this is a start            if (lpControlMsg^.ControlCode = MB_START) then            begin               // Free existing multi part message               FreeAndNil(FMultiMsg);               // Create new multi part message               FMultiMsg:=TPipeMultiMsg.Create;            end            // Check to see if this is an end            else if (lpControlMsg^.ControlCode = MB_END) then            begin               // The multi part message must be assigned               if Assigned(FMultiMsg) then               begin                  // Resource protection                  try                     // Rewind the stream                     FMultiMsg.Stream.Position:=0;                     // Send the message to the notification window                     SafeSendMessage(WM_PIPEMESSAGE, FPipe, Integer(FMultiMsg.Stream));                  finally                     // Free the multi part message                     FreeAndNil(FMultiMsg);                  end;               end;            end            else               // Unknown code               FreeAndNil(FMultiMsg);         end         else         begin            // Check for multi part message packet            if Assigned(FMultiMsg) then               // Add data to existing stream               FMultiMsg.Stream.Write(FRcvStream.Memory^, FRcvStream.Size)            else               // Send the message to the notification window               SafeSendMessage(WM_PIPEMESSAGE, FPipe, Integer(FRcvStream));         end;      end      // Check to see if we are in a multi part message      else if Assigned(FMultiMsg) then         // Add data to existing stream         FMultiMsg.Stream.Write(FRcvStream.Memory^, FRcvStream.Size)      else         // Send the message to the notification window         SafeSendMessage(WM_PIPEMESSAGE, FPipe, Integer(FRcvStream));   finally      // Clear the read stream      FRcvStream.Clear;   end;
end;
procedure TPipeThread.Execute; var dwEvents: Integer;      bOK: Boolean; begin
  // Resource protection   try      // Check sync base thread against the component main thread      if not(Sync.SyncBaseTID = FNotifyThread) then         // Post message to main window and we are done         PostMessage(FNotify, WM_THREADCTX, 0, 0)      else      begin         // Notify the pipe server of the connect         if FServer then SafeSendMessage(WM_PIPECONNECT, FPipe, 0);         // Loop while not terminated         while not(Terminated) do         begin            // Make sure we always have an outstanding read and write queued up            bOK:=(QueuedRead and QueuedWrite);            // Relinquish time slice            Sleep(0);            // Check current queue state            if bOK then            begin               // Set number of events to wait on               dwEvents:=4;               // If a write is pending, then don't wait on the write queue data event               if FPendingWrite then Dec(dwEvents);               // Handle the event that was signalled (or failure)               case WaitForMultipleObjects(dwEvents, @FEvents, False, INFINITE) of                  // Killed by pipe server                  WAIT_OBJECT_0 :                  begin                     // Resource protection                     try                        // Finish any final read / write (allow them a small delay to finish up)                        if FPendingWrite and (WaitForSingleObject(FEvents[2], DEF_SLEEP) = WAIT_OBJECT_0) then CompleteWrite;                        if FPendingRead and (WaitForSingleObject(FEvents[1], DEF_SLEEP) = WAIT_OBJECT_0) then CompleteRead;                     finally                        // Terminate the thread                        Terminate;                     end;                  end;                  // Read completed                  WAIT_OBJECT_0 + 1 : bOK:=CompleteRead;                  // Write completed                  WAIT_OBJECT_0 + 2 : bOK:=CompleteWrite;                  // Data waiting to be sent                  WAIT_OBJECT_0 + 3 : ;               else                  // General failure                  FErrorCode:=GetLastError;                  // Set status                  bOK:=False;               end;            end;            // Check status            if not(bOK) then            begin               // Call OnError in the main thread if this is not a disconnect. Disconnects               // have their own event, and are not to be considered an error               if not(FErrorCode = ERROR_BROKEN_PIPE) then SafeSendMessage(WM_PIPEERROR_W, FPipe, FErrorCode);               // Terminate the thread               Terminate;            end;         end;      end;   finally      // Disconnect and close the pipe handle at this point      DisconnectAndClose(FPipe, FServer);      // Close all open handles that we own      CloseHandle(FOlapRead.hEvent);      CloseHandle(FOlapWrite.hEvent);   end;
end;
//// TPipeListenThread constructor TPipeListenThread.Create(PipeServer: TPipeServer; KillEvent: THandle); begin
  // Perform inherited create (suspended)   inherited Create(True);

  // Set starting parameters   FreeOnTerminate:=True;   Priority:=tpLower;   FPipeServer:=PipeServer;
  // Increment the thread counter   FPipeServer.FThreadCount.Increment; // *** 2010-12-01: MMC -- Moved this line from just after the "inherited Create(TRUE)" to after the assignment has been made to the property
  FNotifyThread:=FPipeServer.FBaseThread;   FPipeName:=PipeServer.PipeName;   FNotify:=PipeServer.WindowHandle;   InitializeSecurity(FSA);   FPipe:=INVALID_HANDLE_VALUE;   FConnected:=False;   FillChar(FOlapConnect, SizeOf(FOlapConnect), 0);   FOlapConnect.hEvent:=CreateEvent(@FSA, True, False, nil);;   FEvents[0]:=KillEvent;   FEvents[1]:=FOlapConnect.hEvent;
end;
destructor TPipeListenThread.Destroy; begin
  // Resource protection   try      // Resource protection      try         // Close the connect event handle         CloseHandle(FOlapConnect.hEvent);         // Disconnect and free the handle         if IsHandle(FPipe) then         begin            // Check connected state            if FConnected then               // Disconnect and close               DisconnectAndClose(FPipe)            else               // Just close the handle               CloseHandle(FPipe);         end;         // Release memory for security structure         FinalizeSecurity(FSA);      finally         // Decrement the thread counter         FPipeServer.FThreadCount.Decrement;      end;   finally      // Perform inherited      inherited Destroy;   end;
end;
function TPipeListenThread.CreateServerPipe: Boolean; begin
  // Create the outbound pipe first   FPipe:=CreateNamedPipe(PChar(resPipeBaseName + FPipeName), PIPE_OPENMODE, PIPE_MODE, PIPE_INSTANCES, 0, 0, 1000, @FSA);
  // Resource protection   try      // Set result value based on valid handle      if IsHandle(FPipe) then         // Success         FErrorCode:=ERROR_SUCCESS      else         // Get last error         FErrorCode:=GetLastError;   finally      // Success if handle is valid      result:=IsHandle(FPipe);   end;
end;
procedure TPipeListenThread.DoWorker; begin
  // Call the pipe server on the main thread to add a new worker thread   FPipeServer.AddWorkerThread(FPipe);
end;
function TPipeListenThread.SafeSendMessage(Msg: Cardinal; wParam, lParam: Integer): LRESULT; begin
  // Check notify window handle   if IsWindow(FNotify) then      // Send the message      result:=SendMessage(FNotify, Msg, wParam, lParam)   else      // Not a window      result:=0;
end;
procedure TPipeListenThread.Execute; begin
  // Check sync base thread against the component main thread   if not(Sync.SyncBaseTID = FNotifyThread) then      // Post message to main window and we are done      PostMessage(FNotify, WM_THREADCTX, 0, 0)   else   begin      // Thread body      while not(Terminated) do      begin         // Set default state         FConnected:=False;         // Attempt to create first pipe server instance         if CreateServerPipe then         begin            // Connect the named pipe            FConnected:=ConnectNamedPipe(FPipe, @FOlapConnect);            // Handle failure            if not(FConnected) then            begin               // Check the last error code               FErrorCode:=GetLastError;               // Is pipe connected?               if (FErrorCode = ERROR_PIPE_CONNECTED) then                  // Set connected state                  FConnected:=True               // IO pending?               else if(FErrorCode = ERROR_IO_PENDING) then               begin                  // Wait for a connect or kill signal                  case WaitForMultipleObjects(2, @FEvents, False, INFINITE) of                     WAIT_FAILED : FErrorCode:=GetLastError;                     WAIT_OBJECT_0 : Terminate;                     WAIT_OBJECT_0 + 1 : FConnected:=True;                  end;               end;            end;         end;         // If we are not connected at this point then we had a failure         if not(FConnected) then         begin            // Resource protection            try               // No error if terminated or client connects / disconnects (no data)               if not(Terminated or (FErrorCode = ERROR_NO_DATA)) then SafeSendMessage(WM_PIPEERROR_L, FPipe, FErrorCode);            finally               // Close and clear               CloseHandleClear(FPipe);            end;         end         else            // Notify server of connect            Synchronize(DoWorker);      end;   end;
end;
//// TThreadCounter constructor TThreadCounter.Create; begin
  // Perform inherited   inherited Create;
  // Create critical section lock   InitializeCriticalSection(FLock);
  // Create event for empty state   FEmpty:=CreateEvent(nil, True, True, nil);
  // Set the starting count   FCount:=0;
end;
destructor TThreadCounter.Destroy; begin
  // Resource protection   try      // Close the event handle      CloseHandleClear(FEmpty);      // Delete the critical section      DeleteCriticalSection(FLock);   finally      // Perform inherited      inherited Destroy;   end;
end;
function TThreadCounter.GetCount: Integer; begin
  // Enter critical section   EnterCriticalSection(FLock);
  // Resource protection   try      // Return the count      result:=FCount;   finally      // Leave the critical section      LeaveCriticalSection(FLock);   end;
end;
procedure TThreadCounter.Increment; begin
  // Enter critical section   EnterCriticalSection(FLock);
  // Resource protection   try      // Increment the count      Inc(FCount);      // Reset the empty event      ResetEvent(FEmpty);   finally      // Leave the critical section      LeaveCriticalSection(FLock);   end;
end;
procedure TThreadCounter.Decrement; begin
  // Enter critical section   EnterCriticalSection(FLock);
  // Resource protection   try      // Decrement the count      if (FCount > 0) then Dec(FCount);      // Signal empty event if count is zero      if (FCount = 0) then SetEvent(FEmpty);   finally      // Leave the critical section      LeaveCriticalSection(FLock);   end;
end;
procedure TThreadCounter.WaitForEmpty; begin
  // Wait until the empty event is signalled   while (MsgWaitForMultipleObjects(1, FEmpty, False, INFINITE, QS_SENDMESSAGE) = WAIT_OBJECT_0 + 1) do   begin      // Messages waiting to be read      FlushMessages;   end;
end;
//// TWriteQueue constructor TWriteQueue.Create; begin
  // Perform inherited   inherited Create;
  // Set defaults   FHead:=nil;   FTail:=nil;   FMutex:=0;   FDataEv:=0;   FDataSize:=0;   FEmptyEv:=0;
  // Create mutex to allow for single access into the write queue   FMutex:=CreateMutex(nil, False, nil);
  // Check mutex handle   if (FMutex = 0) then      // Raise exception      RaiseWindowsError   else   begin      // Create event to signal when we have data to write      FDataEv:=CreateEvent(nil, True, False, nil);      // Check event handle      if (FDataEv = 0) then         // Raise exception         RaiseWindowsError      else      begin         // Create event to signal when the queue becomes empty         FEmptyEv:=CreateEvent(nil, True, True, nil);         // Check event handle, raise exception on failure         if (FEmptyEv = 0) then RaiseWindowsError;      end;   end;
end;
destructor TWriteQueue.Destroy; begin
  // Resource protection   try      // Clear      Clear;      // Close the data event handle      CloseHandleClear(FDataEv);      // Close the empty event handle      CloseHandleClear(FEmptyEv);      // Close the mutex handle      CloseHandleClear(FMutex);   finally      // Perform inherited      inherited Destroy;   end;
end;
function TWriteQueue.GetEmpty: Boolean; begin
  // Determine if queue is empty   result:=(FHead = nil);
end;
procedure TWriteQueue.Clear; var lpNode: PWriteNode; begin
  // Access the mutex   WaitForSingleObject(FMutex, INFINITE);
  // Resource protection   try      // Reset the writer event      ResetEvent(FDataEv);      // Resource protection      try         // Resource protection         try            // Free all the items in the stack            while Assigned(FHead) do            begin               // Get the head node and push forward               lpNode:=FHead;               // Resource protection               try                  // Update head                  FHead:=lpNode^.NextNode;                  // Free the pipe write data                  DisposePipeWrite(lpNode^.PipeWrite);               finally                  // Free the queued node                  FreeMem(lpNode);               end;            end;         finally            // Clear the tail            FTail:=nil;            // Reset the data size            FDataSize:=0;         end;      finally         // Signal the empty event         SetEvent(FEmptyEv);      end;   finally      // Release the mutex      ReleaseMutex(FMutex);   end;
end;
function TWriteQueue.NodeSize(Node: PWriteNode): LongWord; begin
  // Result is at least size of TWriteNode plus allocator size   result:=SizeOf(TWriteNode) + SizeOf(Integer);
  // Check pipe write   if Assigned(Node^.PipeWrite) then   begin      // Include the pipe write structure      Inc(result, SizeOf(TPipeWrite) + SizeOf(Integer));      // Include the pipe write data count      Inc(result, Node^.PipeWrite^.Count + SizeOf(Integer));   end;
end;
function TWriteQueue.NewNode(PipeWrite: PPipeWrite): PWriteNode; begin
  // Allocate memory for new node   GetMem(result, SizeOf(TWriteNode));
  // Resource protection   try      // Set the pipe write field      result^.PipeWrite:=PipeWrite;      // Update the data count      Inc(FDataSize, NodeSize(result));   finally      // Make sure the next link is nil      result^.NextNode:=nil;   end;
end;
procedure TWriteQueue.EnqueueControlPacket(ControlCode: DWORD); var lpControlMsg: TPipeMsgBlock; begin
  // Access the mutex   WaitForSingleObject(FMutex, INFINITE);
  // Resource protection   try      // Set control message constants      lpControlMsg.Size:=SizeOf(TPipeMsgBlock);      lpControlMsg.MagicStart:=MB_MAGIC;      lpControlMsg.MagicEnd:=MB_MAGIC;      // Set end control message      lpControlMsg.ControlCode:=ControlCode;      // Create pipe write and queue the data      Enqueue(AllocPipeWrite(lpControlMsg, SizeOf(TPipeMsgBlock)));   finally      // Release the mutex      ReleaseMutex(FMutex);   end;
end;
procedure TWriteQueue.EnqueueEndPacket; begin
  // Enqueue the start   EnqueueControlPacket(MB_END);
end;
procedure TWriteQueue.EnqueueStartPacket; begin
  // Enqueue the start   EnqueueControlPacket(MB_START);
end;
procedure TWriteQueue.EnqueueMultiPacket(PipeWrite: PPipeWrite); var lpData: PChar;      dwSize: Integer; begin
  // Access the mutex   WaitForSingleObject(FMutex, INFINITE);
  // Resource protection   try      // Resource protection      try         // Resource protection         try            // Enqueue the start packet            EnqueueStartPacket;            // Get pointer to pipe write data            lpData:=PipeWrite^.Buffer;            // While count of data to move            while (PipeWrite^.Count > 0) do            begin               // Determine packet size               if (PipeWrite^.Count > MAX_BUFFER) then                  // Full packet size                  dwSize:=MAX_BUFFER               else                  // Final packet                  dwSize:=PipeWrite^.Count;               // Resource protection               try                  // Create pipe write and queue the data                  Enqueue(AllocPipeWrite(lpData^, dwSize));                  // Increment the data pointer                  Inc(lpData, dwSize);               finally                  // Decrement the remaining count                  Dec(PipeWrite^.Count, dwSize);               end;            end;         finally            // Enqueue the end packet            EnqueueEndPacket;         end;      finally         // Dispose of the original pipe write         DisposePipeWrite(PipeWrite);      end;   finally      // Release the mutex      ReleaseMutex(FMutex);   end;
end;
procedure TWriteQueue.UpdateState; begin
  // Check head node   if Assigned(FHead) then   begin      // Signal data event      SetEvent(FDataEv);      // Reset empty event      ResetEvent(FEmptyEv);   end   else   begin      // Reset data event      ResetEvent(FDataEv);      // Signal empty event      SetEvent(FEmptyEv);   end;
end;
procedure TWriteQueue.Enqueue(PipeWrite: PPipeWrite); var lpNode: PWriteNode; begin
  // Access the mutex   WaitForSingleObject(FMutex, INFINITE);
  // Resource protection   try      // Check pipe write      if Assigned(PipeWrite) then      begin         // Resource protection         try            // Check count of bytes in the pipe write record            if (PipeWrite^.Count > MAX_BUFFER) then               // Need to create multi packet message               EnqueueMultipacket(PipeWrite)            else            begin               // Create a new node               lpNode:=NewNode(PipeWrite);               // Resource protection               try                  // Make this the last item in the queue                  if Assigned(FTail) then                     // Update the next node                     FTail^.NextNode:=lpNode                  else                     // Set the head node                     FHead:=lpNode;               finally                  // Update the new tail                  FTail:=lpNode;               end;            end;         finally            // Update event state            UpdateState;         end;      end;   finally      // Release the mutex      ReleaseMutex(FMutex);   end;
end;
function TWriteQueue.Dequeue: PPipeWrite; var lpNode: PWriteNode; begin
  // Access the mutex   WaitForSingleObject(FMutex, INFINITE);
  // Resource protection   try      // Resource protection      try         // Remove the first item from the queue         if Assigned(FHead) then         begin            // Get head node            lpNode:=FHead;            // Update the data count            Dec(FDataSize, NodeSize(lpNode));            // Resource protection            try               // Set the return data               result:=lpNode^.PipeWrite;               // Does head = Tail?               if (FHead = FTail) then FTail:=nil;               // Update the head               FHead:=lpNode^.NextNode;            finally               // Free the memory for the node               FreeMem(lpNode);            end;         end         else            // No queued data            result:=nil;      finally         // Update state         UpdateState;      end;   finally      // Release the mutex      ReleaseMutex(FMutex);   end;
end;
//// TPipeMultiMsg procedure TPipeMultiMsg.CreateTempBacking; var lpszPath: Array [0..MAX_PATH] of Char;      lpszFile: Array [0..MAX_PATH] of Char; begin
  // Resource protection   try      // Attempt to get temp file      if (GetTempPath(MAX_PATH, lpszPath) > 0) and (GetTempFileName(@lpszPath, MB_PREFIX, 0, @lpszFile) > 0) then         // Open the temp file         FHandle:=CreateFile(@lpszFile, GENERIC_READ or GENERIC_WRITE, 0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_TEMPORARY or FILE_FLAG_DELETE_ON_CLOSE, 0)      else         // Failed to get temp filename         FHandle:=INVALID_HANDLE_VALUE;   finally      // If we failed to open a temp file then we will use memory for data backing      if IsHandle(FHandle) then         // Create handle stream         FStream:=THandleStream.Create(FHandle)      else         // Create fast memory stream         FStream:=TFastMemStream.Create;   end;
end;
constructor TPipeMultiMsg.Create; begin
  // Perform inherited   inherited Create;
  // Create temp file backing   CreateTempBacking;
end;
destructor TPipeMultiMsg.Destroy; begin
  // Resource protection   try      // Free the stream      FreeAndNil(FStream);      // Close handle if open      if IsHandle(FHandle) then CloseHandle(FHandle);   finally      // Perform inherited      inherited Destroy;   end;
end;
//// TFastMemStream function TFastMemStream.Realloc(var NewCapacity: Longint): Pointer; var dwDelta: Integer;      lpMemory: Pointer; begin
  // Get current memory pointer   lpMemory:=Memory;
  // Resource protection   try      // Calculate the delta to be applied to the capacity      if (NewCapacity > 0) then      begin         // Check new capacity         if (NewCapacity > MaxWord) then            // Delta is 1/4 of desired capacity            dwDelta:=NewCapacity div 4         else            // Minimum allocation of 64 KB            dwDelta:=MaxWord;         // Update by delta         Inc(NewCapacity, dwDelta);      end;      // Determine if capacity has changed      if not(NewCapacity = Capacity) then      begin         // Check for nil alloc         if (NewCapacity = 0) then         begin            // Release the memory            FreeMem(lpMemory);            // Clear result            lpMemory:=nil;         end         else         begin            // Check current capacity            if (Capacity = 0) then               // Allocate memory               lpMemory:=AllocMem(NewCapacity)            else               // Reallocate memory               ReallocMem(lpMemory, NewCapacity);         end;      end;   finally      // Return modified pointer      result:=lpMemory;   end;
end;
//// Thread window procedure function ThreadWndProc(Window: HWND; Message, wParam, lParam: Longint): Longint; stdcall; begin
  // Handle the window message   case Message of      // Exceute the method in thread      CM_EXECPROC :      begin         // The lParam constains the thread sync information         with TThreadSync(lParam) do         begin            // Set message result            result:=0;            // Exception trap            try               // Clear the exception               FSyncRaise:=nil;               // Call the method               FMethod;            except               {$IFNDEF DELPHI_6_ABOVE}               if not(RaiseList = nil) then               begin                  // Get exception object from frame                  FSyncRaise:=PRaiseFrame(RaiseList)^.ExceptObject;                  // Clear frame exception object                  PRaiseFrame(RaiseList)^.ExceptObject:=nil;               end;               {$ELSE}               FSyncRaise:=AcquireExceptionObject;               {$ENDIF}            end;         end;      end;      // Thead destroying      CM_DESTROYWINDOW :      begin         // Get instance of sync manager         TSyncManager.Instance.DoDestroyWindow(TSyncInfo(lParam));         // Set message result         result:=0;      end;   else      // Call the default window procedure      result:=DefWindowProc(Window, Message, wParam, lParam);   end;
end;
//// TSyncManager constructor TSyncManager.Create; begin
  // Perform inherited   inherited Create;
  // Initialize the critical section   InitializeCriticalSection(FThreadLock);
  // Create the info list   FList:=TList.Create;
end;
destructor TSyncManager.Destroy; var dwIndex: Integer; begin
  // Resource protection   try      // Free all info records      for dwIndex:=Pred(FList.Count) downto 0 do FreeSyncInfo(TSyncInfo(FList[dwIndex]));      // Free the list      FList.Free;      // Delete the critical section      DeleteCriticalSection(FThreadLock);   finally      // Call inherited      inherited Destroy;   end;
end;
class function TSyncManager.Instance: TSyncManager; begin
  // Enter critical section   EnterCriticalSection(InstCritSect);
  // Resource protection   try      // Check global instance, create if needed      if (SyncManager = nil) then SyncManager:=TSyncManager.Create;      // Return instance of sync manager      result:=SyncManager   finally      // Leave critical section      LeaveCriticalSection(InstCritSect);   end;
end;
function TSyncManager.AllocateWindow: HWND; var clsTemp: TWndClass;      bClassReg: Boolean; begin
  // Set instance handle   ThreadWndClass.hInstance:=HInstance;   ThreadWndClass.lpfnWndProc:=@ThreadWndProc;
  // Attempt to get class info   bClassReg:=GetClassInfo(HInstance, ThreadWndClass.lpszClassName, clsTemp);
  // Ensure the class is registered and the window procedure is the default window proc   if not(bClassReg) or not(clsTemp.lpfnWndProc = @ThreadWndProc) then   begin      // Unregister if already registered      if bClassReg then Windows.UnregisterClass(ThreadWndClass.lpszClassName, HInstance);      // Register      Windows.RegisterClass(ThreadWndClass);   end;
  // Create the thread window   result:=CreateWindowEx(0, ThreadWndClass.lpszClassName, '', 0, 0, 0, 0, 0, 0, 0, HInstance, nil);
end;
procedure TSyncManager.AddThread(ThreadSync: TThreadSync); var lpInfo: TSyncInfo; begin
  // Enter critical section   EnterCriticalSection(FThreadLock);
  // Resource protection   try      // Find the info using the base thread id      lpInfo:=FindSyncInfo(ThreadSync.SyncBaseTID);      // Resource protection      try         // Check assignment         if (lpInfo = nil) then         begin            // Create new info record            lpInfo:=TSyncInfo.Create;            // Set base thread id            lpInfo.FSyncBaseTID:=ThreadSync.SyncBaseTID;            // Add info to list            FList.Add(lpInfo);         end;         // Check thread count, create window if needed         if (lpInfo.FThreadCount = 0) then lpInfo.FThreadWindow:=AllocateWindow;      finally         // Increment the thread count         Inc(lpInfo.FThreadCount);      end;   finally      // Leave the critical section      LeaveCriticalSection(FThreadLock);   end;
end;
procedure TSyncManager.RemoveThread(ThreadSync: TThreadSync); var lpInfo: TSyncInfo; begin
  // Enter critical section   EnterCriticalSection(FThreadLock);
  // Resource protection   try      // Find the info using the base thread id      lpInfo:=FindSyncInfo(ThreadSync.SyncBaseTID);      // Check assignment      if Assigned(lpInfo) then PostMessage(lpInfo.FThreadWindow, CM_DESTROYWINDOW, 0, Longint(lpInfo));   finally      // Leave the critical section      LeaveCriticalSection(FThreadLock);   end;
end;
procedure TSyncManager.DoDestroyWindow(Info: TSyncInfo); begin
  // Enter critical section   EnterCriticalSection(FThreadLock);
  // Resource protection   try      // Decrement the thread count      Dec(Info.FThreadCount);      // Check for zero threads      if (Info.FThreadCount = 0) then FreeSyncInfo(Info);   finally      // Leave the critical section      LeaveCriticalSection(FThreadLock);   end;
end;
procedure TSyncManager.FreeSyncInfo(Info: TSyncInfo); begin
  // Check thread window   if not(Info.FThreadWindow = 0) then   begin      // Resource protection      try         // Destroy window         DestroyWindow(Info.FThreadWindow);         // Remove from list         FList.Remove(Info);      finally         // Free the class structure         Info.Free;      end;   end;
end;
procedure TSyncManager.Synchronize(ThreadSync: TThreadSync); var lpInfo: TSyncInfo; begin
  // Find the info using the base thread id   lpInfo:=FindSyncInfo(ThreadSync.SyncBaseTID);
  // Check assignment, send message to thread window   if Assigned(lpInfo) then SendMessage(lpInfo.FThreadWindow, CM_EXECPROC, 0, Longint(ThreadSync));
end;
function TSyncManager.FindSyncInfo(SyncBaseTID: LongWord): TSyncInfo; var dwIndex: Integer; begin
  // Set default result   result:=nil;
  // Locate in list   for dwIndex:=0 to Pred(FList.Count) do   begin      // Compare thread id's      if (TSyncInfo(FList[dwIndex]).FSyncBaseTID = SyncBaseTID) then      begin         // Found the info structure         result:=TSyncInfo(FList[dwIndex]);         // Done processing         break;      end;   end;
end;
//// TThreadSync constructor TThreadSync.Create; begin
  // Perform inherited   inherited Create;
  // Set the base thread id   FSyncBaseTID:=GetCurrentThreadId;
  // Add self to sync manager   TSyncManager.Instance.AddThread(Self);
end;
destructor TThreadSync.Destroy; begin
  // Resource protection   try      // Remove self from sync manager      TSyncManager.Instance.RemoveThread(Self);   finally      // Perform inherited      inherited Destroy;   end;
end;
procedure TThreadSync.Synchronize(Method: TThreadMethod); begin
  // Clear sync raise exception object   FSyncRaise:=nil;
  // Set the method pointer   FMethod:=Method;
  // Resource protection   try      // Have the sync manager call the method      TSyncManager.Instance.Synchronize(Self);   finally      // Check to see if the exception object was set      if Assigned(FSyncRaise) then raise FSyncRaise;   end;
end;
//// TThreadEx constructor TThreadEx.Create(CreateSuspended: Boolean); begin
  // Create the sync   FSync:=TThreadSync.Create;
  // Perform inherited   inherited Create(CreateSuspended);
end;
destructor TThreadEx.Destroy; begin
  // Resource protection   try      // Free the sync object      FSync.Free;   finally      // Perform inherited      inherited Destroy;   end;
end;
procedure TThreadEx.DoTerminate; begin
  // Overide the DoTerminate and don't call inherited   if Assigned(OnTerminate) then Sync.Synchronize(HandleTerminate);
end;
procedure TThreadEx.HandleTerminate; begin
  // Call OnTerminate if assigned   if Assigned(OnTerminate) then OnTerminate(Self);
end;
procedure TThreadEx.Synchronize(Method: TThreadMethod); begin
  // Call the sync's version of synchronize   Sync.Synchronize(Method);
end;
procedure TThreadEx.SafeSynchronize(Method: TThreadMethod); begin
  // Exception trap   try      // Call synchronize      Sync.Synchronize(Method);   except      // Eat the actual exception, just call terminate on the thread      Terminate;   end;
end;
procedure TThreadEx.Wait; var hThread: THandle;      dwExit: DWORD; begin
  // Set the thread handle   hThread:=Handle;
  // Check current thread against the sync thread id   if (GetCurrentThreadID = Sync.SyncBaseTID) then   begin      // Message wait      while (MsgWaitForMultipleObjects(1, hThread, False, INFINITE, QS_ALLINPUT) = WAIT_OBJECT_0 + 1) do      begin         // Flush the messages         FlushMessages;         // Check thread state (because the handle is not duplicated, it can become invalid. Testing         // WaitForSingleObject(Handle, 0) even returns WAIT_TIMEOUT for the invalid handle)         if not(GetExitCodeThread(hThread, dwExit)) or not(dwExit = STILL_ACTIVE) then break;      end;   end   else      // Wait is not being called from base thread id, so use WaitForSingleObject      WaitForSingleObject(hThread, INFINITE);
end;
//// Console helper functions type   TConsoleEvent = function(dwCtrlEvent: DWORD; dwProcessGroupId: DWORD): BOOL; stdcall;   TConsoleHwnd = function(): HWND; stdcall;
function ConsoleWindow(ConsoleHwnd: TConsoleHwnd): HWND; stdcall; begin
  // Check function pointer   if Assigned(@ConsoleHwnd) then      // Call function      result:=ConsoleHwnd()   else      // Return zero      result:=0;
end;
function GetConsoleWindow(ProcessHandle: THandle): HWND; var lpConsoleHwnd: Pointer;      hThread: THandle;      dwSize: DWORD;      dwWrite: DWORD;      dwExit: DWORD; begin
  // Get size of function that we need to inject   dwSize:=PChar(@GetConsoleWindow) - PChar(@ConsoleWindow);
  // Allocate memory in remote process   lpConsoleHwnd:=VirtualAllocEx(ProcessHandle, nil, dwSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
  // Check memory, write code from this process   if Assigned(lpConsoleHwnd) then   begin      // Write memory      WriteProcessMemory(ProcessHandle, lpConsoleHwnd, @ConsoleWindow, dwSize, dwWrite);      // Resource protection      try         // Create remote thread starting at the injected function, passing in the address to GetConsoleWindow         hThread:=CreateRemoteThread(ProcessHandle, nil, 0, lpConsoleHwnd, GetProcAddress(GetModuleHandle(kernel32), 'GetConsoleWindow'), 0, DWORD(Pointer(nil)^));         // Check thread         if (hThread = 0) then            // Failed to create thread            result:=0         else         begin            // Resource protection            try               // Wait for the thread to complete               WaitForSingleObject(hThread, INFINITE);               // Get the exit code from the thread               if GetExitCodeThread(hThread, dwExit) then                  // Set return                  result:=dwExit               else                  // Failed to get exit code                  result:=0;            finally               // Close the thread handle               CloseHandle(hThread);            end;         end;      finally         // Free allocated memory         VirtualFreeEx(ProcessHandle, lpConsoleHwnd, 0, MEM_RELEASE);      end;   end   else      // Failed to create remote injected function      result:=0;
end;
function GetConsoleWindowEx(ProcessHandle: THandle; ProcessID, ThreadID: DWORD): HWND; var lpConInfo: TPipeConsoleInfo; begin
  // Call the optimal routine first   result:=GetConsoleWindow(ProcessHandle);
  // Check return handle   if (result = 0) then   begin      // Clear the window handle      lpConInfo.Window:=0;      // Resource protection      try         // Set process info         lpConInfo.ProcessID:=ProcessID;         lpConInfo.ThreadID:=ThreadID;         // Enumerate the windows on the console thread         EnumWindows(@EnumConsoleWindows, Integer(@lpConInfo));      finally         // Return the window handle         result:=lpConInfo.Window;      end;   end;
end;
function CtrlBreak(ConsoleEvent: TConsoleEvent): DWORD; stdcall; begin
  // Generate the control break   result:=DWORD(ConsoleEvent(CTRL_BREAK_EVENT, 0));
end;
function CtrlC(ConsoleEvent: TConsoleEvent): DWORD; stdcall; begin
  // Generate the control break   result:=DWORD(ConsoleEvent(CTRL_C_EVENT, 0));
end;
function ExecConsoleEvent(ProcessHandle: THandle; Event: DWORD): Boolean; var lpCtrlEvent: Pointer;      hThread: THandle;      dwSize: DWORD;      dwWrite: DWORD;      dwExit: DWORD; begin
  // Check event   case Event of      // Control C      CTRL_C_EVENT :      begin         // Get size of function that we need to inject         dwSize:=PChar(@ExecConsoleEvent) - PChar(@CtrlC);         // Allocate memory in remote process         lpCtrlEvent:=VirtualAllocEx(ProcessHandle, nil, dwSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);         // Check memory, write code from this process         if Assigned(lpCtrlEvent) then WriteProcessMemory(ProcessHandle, lpCtrlEvent, @CtrlC, dwSize, dwWrite);      end;      // Control break      CTRL_BREAK_EVENT :      begin         // Get size of function that we need to inject         dwSize:=PChar(@CtrlC) - PChar(@CtrlBreak);         // Allocate memory in remote process         lpCtrlEvent:=VirtualAllocEx(ProcessHandle, nil, dwSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);         // Check memory, write code from this process         if Assigned(lpCtrlEvent) then WriteProcessMemory(ProcessHandle, lpCtrlEvent, @CtrlBreak, dwSize, dwWrite);      end;   else      // Not going to handle      lpCtrlEvent:=nil;   end;
  // Check remote function address   if Assigned(lpCtrlEvent) then   begin      // Resource protection      try         // Create remote thread starting at the injected function, passing in the address to GenerateConsoleCtrlEvent         hThread:=CreateRemoteThread(ProcessHandle, nil, 0, lpCtrlEvent, GetProcAddress(GetModuleHandle(kernel32), 'GenerateConsoleCtrlEvent'), 0, DWORD(Pointer(nil)^));         // Check thread         if (hThread = 0) then            // Failed to create thread            result:=False         else         begin            // Resource protection            try               // Wait for the thread to complete               WaitForSingleObject(hThread, INFINITE);               // Get the exit code from the thread               if GetExitCodeThread(hThread, dwExit) then                  // Set return                  result:=not(dwExit = 0)               else                  // Failed to get exit code                  result:=False;            finally               // Close the thread handle               CloseHandle(hThread);            end;         end;      finally         // Free allocated memory         VirtualFreeEx(ProcessHandle, lpCtrlEvent, 0, MEM_RELEASE);      end;   end   else      // Failed to create remote injected function      result:=False;
end;
procedure ExitProcessEx(ProcessHandle: THandle; ExitCode: DWORD); var hKernel: HMODULE;      hThread: THandle; begin
  // Get handle to kernel32   hKernel:=GetModuleHandle(kernel32);
  // Check handle   if not(hKernel = 0) then   begin      // Create a remote thread in the external process and have it call ExitProcess (tricky)      hThread:=CreateRemoteThread(ProcessHandle, nil, 0, GetProcAddress(hKernel, 'ExitProcess'), Pointer(ExitCode), 0, DWORD(Pointer(nil)^));      // Check the thread handle      if (hThread = 0) then         // Just terminate the process         TerminateProcess(ProcessHandle, ExitCode)      else      begin         // Resource protection         try            // Wait for the thread to complete            WaitForSingleObject(hThread, INFINITE);         finally            // Close the handle            CloseHandle(hThread);         end;      end;   end   else      // Attempt to use the process handle from the create process call      TerminateProcess(ProcessHandle, ExitCode);
end;
//// Pipe helper functions procedure ClearOverlapped(var Overlapped: TOverlapped; ClearEvent: Boolean = False); begin
  // Check to see if all fields should be clered   if ClearEvent then      // Clear whole structure      FillChar(Overlapped, SizeOf(Overlapped), 0)   else   begin      // Clear all fields except for the event handle      Overlapped.Internal:=0;      Overlapped.InternalHigh:=0;      Overlapped.Offset:=0;      Overlapped.OffsetHigh:=0;   end;
end;
procedure CloseHandleClear(var Handle: THandle); begin
  // Resource protection   try      // Check for invalid handle or zero      if IsHandle(Handle) then CloseHandle(Handle);   finally      // Set to invalid handle      Handle:=INVALID_HANDLE_VALUE;   end;
end;
procedure DisconnectAndClose(Pipe: HPIPE; IsServer: Boolean = True); begin
  // Check handle   if IsHandle(Pipe) then   begin      // Resource protection      try         // Cancel overlapped IO on the handle         CancelIO(Pipe);         // Flush file buffer         FlushFileBuffers(Pipe);         // Disconnect the server end of the named pipe if flag is set         if IsServer then DisconnectNamedPipe(Pipe);      finally         // Close the pipe handle         CloseHandle(Pipe);      end;   end;
end;
procedure RaiseWindowsError; begin
  {$IFDEF DELPHI_6_ABOVE}   RaiseLastOSError;   {$ELSE}   RaiseLastWin32Error;   {$ENDIF}
end;
procedure FlushMessages; var lpMsg: TMsg; begin
  // Flush the message queue for the calling thread   while PeekMessage(lpMsg, 0, 0, 0, PM_REMOVE) do   begin      // Translate the message      TranslateMessage(lpMsg);      // Dispatch the message      DispatchMessage(lpMsg);      // Allow other threads to run      Sleep(0);   end;
end;
function IsHandle(Handle: THandle): Boolean; begin
  // Determine if a valid handle (only by value)   result:=not((Handle = 0) or (Handle = INVALID_HANDLE_VALUE));
end;
function ComputerName: String; var dwSize: DWORD; begin
  // Set max size   dwSize:=Succ(MAX_PATH);
  // Resource protection   try      // Set string length      SetLength(result, dwSize);      // Attempt to get the computer name      if not(GetComputerName(@result[1], dwSize)) then dwSize:=0;   finally      // Truncate string      SetLength(result, dwSize);   end;
end;
function AllocPipeWriteWithPrefix(const Prefix; PrefixCount: Integer; const Buffer; Count: Integer): PPipeWrite; var lpBuffer: PChar; begin
  // Allocate memory for the result   result:=AllocMem(SizeOf(TPipeWrite));
  // Set the count of the buffer   result^.Count:=PrefixCount + Count;
  // Allocate enough memory to store the prefix and data buffer   result^.Buffer:=AllocMem(result^.Count);
  // Set buffer pointer   lpBuffer:=result^.Buffer;
  // Resource protection   try      // Move the prefix data in      System.Move(Prefix, lpBuffer^, PrefixCount);      // Increment the buffer position      Inc(lpBuffer, PrefixCount);   finally      // Move the buffer data in      System.Move(Buffer, lpBuffer^, Count);   end;
end;
function AllocPipeWrite(const Buffer; Count: Integer): PPipeWrite; begin
  // Allocate memory for the result   result:=AllocMem(SizeOf(TPipeWrite));
  // Resource protection   try      // Set the count of the buffer      result^.Count:=Count;      // Allocate enough memory to store the data buffer      result^.Buffer:=AllocMem(Count);   finally      // Move data to the buffer      System.Move(Buffer, result^.Buffer^, Count);   end;
end;
procedure DisposePipeWrite(var PipeWrite: PPipeWrite); begin
  // Check pointer   if Assigned(PipeWrite) then   begin      // Resource protection      try         // Resource protection         try            // Dispose of the memory being used by the pipe write structure            if Assigned(PipeWrite^.Buffer) then FreeMem(PipeWrite^.Buffer);         finally            // Free the memory record            FreeMem(PipeWrite);         end;      finally         // Clear the pointer         PipeWrite:=nil;      end;   end;
end;
function EnumConsoleWindows(Window: HWND; lParam: Integer): BOOL; stdcall; var lpConInfo: PPipeConsoleInfo; begin
  // Get the console info   lpConInfo:=Pointer(lParam);
  // Get the thread id and compare against the passed structure   if (lpConInfo^.ThreadID = GetWindowThreadProcessId(Window, nil)) then   begin      // Found the window, return the handle      lpConInfo^.Window:=Window;      // Stop enumeration      result:=False;   end   else      // Keep enumerating      result:=True;
end;
procedure CheckPipeName(Value: String); begin
  // Validate the pipe name   if (Pos('\', Value) > 0) or (Length(Value) > MAX_NAME) or (Length(Value) = 0) then raise EPipeException.CreateRes(@resBadPipeName);
end;
//// Security helper functions ///////////////////////////////////////////////// procedure InitializeSecurity(var SA: TSecurityAttributes); var sd: PSecurityDescriptor; begin
  // Allocate memory for the security descriptor   sd:=AllocMem(SECURITY_DESCRIPTOR_MIN_LENGTH);
  // Initialize the new security descriptor   if InitializeSecurityDescriptor(sd, SECURITY_DESCRIPTOR_REVISION) then   begin      // Add a NULL descriptor ACL to the security descriptor      if SetSecurityDescriptorDacl(sd, True, nil, False) then      begin         // Set up the security attributes structure         SA.nLength:=SizeOf(TSecurityAttributes);         SA.lpSecurityDescriptor:=sd;         SA.bInheritHandle:=True;      end      else         // Failed to init the sec descriptor         RaiseWindowsError;   end   else      // Failed to init the sec descriptor      RaiseWindowsError;
end;
procedure FinalizeSecurity(var SA: TSecurityAttributes); begin
  // Release memory that was assigned to security descriptor   if Assigned(SA.lpSecurityDescriptor) then   begin      // Reource protection      try         // Free memory         FreeMem(SA.lpSecurityDescriptor);      finally         // Clear pointer         SA.lpSecurityDescriptor:=nil;      end;   end;
end;
//// Object instance handling function StdWndProc(Window: HWND; Message, WParam: Longint; LParam: Longint): Longint; stdcall; assembler; asm   xor eax, eax   push eax   push LParam   push WParam   push Message   mov edx, esp   mov eax, [ecx].LongInt[4]   call [ecx].Pointer   add esp, 12   pop eax end;
function CalcJmpOffset(Src, Dest: Pointer): Longint; begin
  // Calculate the jump offset   result:=Longint(Dest) - (Longint(Src) + 5);
end;
function CalcJmpTarget(Src: Pointer; Offs: integer): Pointer; begin
  // Calculate the jump target   Integer(result):=Offs + (Longint(Src) + 5);
end;
function GetInstanceBlock(ObjectInstance: Pointer): PInstanceBlock; var lpInst: PObjectInstance; begin
  // Cast as object instance   lpInst:=ObjectInstance;
  // Check instance   if (lpInst = nil) then      // Return nil      result:=nil   else      // Get instance block      Pointer(Result):=Pointer(LongInt(CalcJmpTarget(lpInst, lpInst^.Offset)) - SizeOf(Word) - SizeOf(PInstanceBlock));
end;
function MakeObjectInstance(Method: TWndMethod): Pointer; var lpBlock: PInstanceBlock;      lpInst: PObjectInstance; const   BlockCode: Array [1..2] of Byte = (                                                $59, // POP ECX                                                $E9 // JMP StdWndProc                                             );   PageSize = 4096; begin
  // Enter critical section   EnterCriticalSection(InstCritSect);
  // Resource protection   try      // Check free list      if (InstFreeList = nil) then      begin         // Allocate a new instance block         lpBlock:=VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);         // Update the next pointer         lpBlock^.Next:=InstBlockList;         // Set block code         Word(lpBlock^.Code):=Word(BlockCode);         // Set wndproc pointer         lpBlock^.WndProcPtr:=Pointer(CalcJmpOffset(@lpBlock^.Code[2], @StdWndProc));         // Set block counter         lpBlock^.Counter:=0;         // Update all block instances         lpInst:=@lpBlock^.Instances;         repeat            // Set call to near pointer offser            lpInst^.Code:=$E8;            // Calculate the jump offset            lpInst^.Offset:=CalcJmpOffset(lpInst, @lpBlock^.Code);            // Set next instance            lpInst^.Next:=InstFreeList;            // Update the instance list            InstFreeList:=lpInst;            // Push pointer forward            Inc(LongInt(lpInst), SizeOf(TObjectInstance));         until (Longint(lpInst)-Longint(lpBlock) >= SizeOf(TInstanceBlock));         // Update the block list         InstBlockList:=lpBlock;      end;      // Get instance from free list      result:=InstFreeList;      // Next instance in free list      lpInst:=InstFreeList;      InstFreeList:=lpInst^.Next;      // Update the moethod pointer      lpInst^.Method:=Method;      // Increment the block counter      Inc(GetInstanceBlock(lpInst)^.Counter);   finally      // Leave the critical section      LeaveCriticalSection(InstCritSect);   end;
end;
function FreeInstanceBlock(Block: Pointer): Boolean; var lpBlock: PInstanceBlock;      lpInst: PObjectInstance;      lpPrev: PObjectInstance;      lpNext: PObjectInstance; begin
  // Get the instance block   lpBlock:=Block;
  // Check the block   if (lpBlock = nil) or (lpBlock^.Counter > 0) then      // Cant free instance block      result:=False   else   begin      // Get free list      lpInst:=InstFreeList;      // Set previous      lpPrev:=nil;      // While assigned      while Assigned(lpInst) do      begin         // Get next instance         lpNext:=lpInst^.Next;         // Check instance block against passed block         if (GetInstanceBlock(lpInst) = lpBlock) then         begin            // Check previous            if Assigned(lpPrev) then lpPrev^.Next:=lpNext;            // Check against list            if (lpInst = InstFreeList) then InstFreeList:=lpNext;         end;         // Update previous         lpPrev:=lpInst;         // Next instance         lpInst:=lpNext;      end;      // Free the block of memory      VirtualFree(lpBlock, 0, MEM_RELEASE);      // Success      result:=True;   end;
end;
procedure FreeInstanceBlocks; var lpPrev: PInstanceBlock;      lpNext: PInstanceBlock;      lpBlock: PInstanceBlock; begin
  // Set previous to nil   lpPrev:=nil;
  // Get current block   lpBlock:=InstBlockList;
  // While assigned   while Assigned(lpBlock) do   begin      // Get next block      lpNext:=lpBlock^.Next;      // Attempt to free      if FreeInstanceBlock(lpBlock) then      begin         // Relink blocks         if Assigned(lpPrev) then lpPrev^.Next:=lpNext;         // Reset list if needed         if (lpBlock = InstBlockList) then InstBlockList:=lpNext;      end      else         // Failed to free block         lpBlock:=nil;      // Update previous      lpPrev:=lpBlock;      // Next block      lpBlock:=lpNext;   end;
end;
procedure FreeObjectInstance(ObjectInstance: Pointer); var lpBlock: PInstanceBlock; begin
  // Check instance   if Assigned(ObjectInstance) then   begin      // Enter critical section      EnterCriticalSection(InstCritSect);      // Resource protection      try         // Get instance block         lpBlock:=GetInstanceBlock(ObjectInstance);         // Check block         if Assigned(lpBlock) then         begin            // Check block counter            if ((lpBlock^.Counter > 0) and (lpBlock^.Counter <= Succ(INSTANCE_COUNT))) then            begin               // Set the next pointer               PObjectInstance(ObjectInstance)^.Next:=InstFreeList;               // Update free list               InstFreeList:=ObjectInstance;               // Decrement the counter               Dec(lpBlock^.Counter);               // If counter is at (or below) zero then free the instance blocks               if (lpBlock^.Counter <= 0) then FreeInstanceBlocks;            end;         end;      finally         // Leave critical section         LeaveCriticalSection(InstCritSect);      end;   end;
end;
function AllocateHWnd(Method: TWndMethod): HWND; var clsTemp: TWndClass;      bClassReg: Boolean; begin
  // Enter critical section   EnterCriticalSection(InstCritSect);
  // Resource protection   try      // Set instance handle      ObjWndClass.hInstance:=HInstance;      // Attempt to get class info      bClassReg:=GetClassInfo(HInstance, ObjWndClass.lpszClassName, clsTemp);      // Ensure the class is registered and the window procedure is the default window proc      if not(bClassReg) or not(clsTemp.lpfnWndProc = @DefWindowProc) then      begin         // Unregister if already registered         if bClassReg then Windows.UnregisterClass(ObjWndClass.lpszClassName, HInstance);         // Register         Windows.RegisterClass(ObjWndClass);      end;      // Create the window      result:=CreateWindowEx(0, ObjWndClass.lpszClassName, '', WS_POPUP, 0, 0, 0, 0, 0, 0, HInstance, nil);      // Set method pointer      if Assigned(Method) then SetWindowLong(result, GWL_WNDPROC, Longint(MakeObjectInstance(Method)));   finally      // Leave critical section      LeaveCriticalSection(InstCritSect);   end;
end;
procedure DeallocateHWnd(Wnd: HWND); var Instance: Pointer; begin
  // Enter critical section   EnterCriticalSection(InstCritSect);
  // Resource protection   try      // Get the window procedure      Instance:=Pointer(GetWindowLong(Wnd, GWL_WNDPROC));      // Resource protection      try         // Destroy the window         DestroyWindow(Wnd);      finally         // If not the default window procedure then free the object instance         if Assigned(Instance) and not(Instance = @DefWindowProc) then FreeObjectInstance(Instance);      end;   finally      // Leave critical section      LeaveCriticalSection(InstCritSect);   end;
end;
procedure CreateMessageQueue; var lpMsg: TMsg; begin
  // Spin a message queue   PeekMessage(lpMsg, 0, WM_USER, WM_USER, PM_NOREMOVE);
end;
procedure Register; begin
  // Register the components under the Win32 tab   RegisterComponents('Win32', [TPipeServer, TPipeClient, TPipeConsole]);
end;
initialization
  // Initialize the critical section for instance handling   InitializeCriticalSection(InstCritSect);
  // If this is a console application then create a message queue   if IsConsole then CreateMessageQueue;
finalization
  // Check sync manager   if Assigned(SyncManager) then FreeAndNil(SyncManager);
  // Delete the critical section for instance handling   DeleteCriticalSection(InstCritSect);
end.
FYI: Phrase searches are enclosed in either single or double quotes
 
 
Originally created by
Tamarack Associates
Thu, 28 Mar 2024 12:37:11 UTC
Copyright © 2009-2024
HREF Tools Corp.