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