Named Pipes unit for Delphi

(Apr 7, 2013)¬†Francoise Piette has updated this source code for Delphi XE3 and put it on his website. I will leave the source code below as-is, but it should be considered out of date and I’d suggest you head to Francoise Piette’s website and grab his updated version.

UPDATED with small change requested by a commenter (Jan 13, 2013)

UPDATED with a newer version of Pipes.pas (the unit was last updated Dec 01, 2010).

I have found named pipes to be great for IPC and communicating between multiple programs in my Delphi applications. They can be cumbersome to write, so I’ve often used Russell Libby’s Pipes.pas unit to create a TPipeClient and TPipeServer design time component.

For detailed directions on how to generally turn this source file into a design-time component, please follow About.com’s Delphi blog instructions here.

Russell’s website no longer appears to be online, so I’m re-posting this Pipes unit in it’s entirety here.

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
 //statement changed 1-12-2013
 //if Assigned(FCounter) then
 // FCounter.Increment;
 if Assigned(Counter) then
 Counter.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.
About these ads

17 comments

  1. Guys, could you send me the unit as a .pas file, so that I don’t have to go through it line by line to fix the format ? It would be great if you found a quick demo showing how to use it. I appreciate your time. My email is: petr at gt51.com
    Thank you

    1. You can get the source code as plain text by going to the beginning of the code on the post, hovering over it, and in the top-right hand corner of the source code 4 icons will appear. Click on the first icon from the left “view source” and it will show you the plain-text source code.

  2. Hello, do you have any example of usage? This component must be legendary because people everywhere mentioned it but no examples/tutorials found :).

  3. Thanks a lot man!! I spent 3 days trying to debug pipes realization in DLL with old version of the code! It just suspended event processing if DLL pipe thread was running in the background, and never sent out message, unless there’s form contained in DLL which should be modal on the screen, but it’s not the solution for me.

    Once i replaced old unit (2005), with this new one, everything went just smoothly, and now DLL process running in the memory handles the pipe threads as the magic.

    Thanks a lot again!!

  4. Hello all…

    Is there a special version for Delphi XE2 for 32bit and 64bit also available? I have seen that the TThread.Resume stuff is deprecated and Start command should be used instead. But how can I make this components work with the 64bit Delphi XE2?

    Any help would be appreciated!

    Thanks a lot in advance!!!

  5. Pingback: Anonymous
  6. Hi! (And thanks for the code).

    Could you correct a bug in the listing? This is a great unit but there’s a nasty error in TPipeThread.Create that will prevent the TPipeThread worker threads from being released. Towards the top of the constructor there’s a couple of lines that read:

    if Assigned(fCounter) then
    fCounter.Increment;

    but fCounter isn’t assigned until later in the method. The code should read:

    if Assigned(Counter) then
    Counter.Increment;

  7. Compiler error is “types of var parameters must be identical”
    To make code compile in Delphi XE and higher, you need to change types of
    of variables dwSize,dwWrite from DWORD to SIZE_T, in two places.

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s