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