GitHub-Mirror/x2log
1
0
Fork 0
mirror of synced 2024-12-22 01:13:08 +01:00
Code Issues Projects Releases Wiki Activity

Added: RunInMainThread property for Event Observer

Browse Source 
Added: Named pipe client - uses standard observers to output log
This commit is contained in:
Mark van Renswoude 2014-05-25 14:20:58 +00:00
parent 7d3a23295c
commit 32847f4988
18 changed files with 831 additions and 372 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
NamedPipeClient/X2LogNamedPipeClient.dpr
View File

@ -3,7 +3,12 @@ program X2LogNamedPipeClient;
uses
Vcl.Forms,
MainFrm in 'source\MainFrm.pas' {MainForm},
X2Log.Intf in '..\X2Log.Intf.pas';
X2Log.Intf in '..\X2Log.Intf.pas',
X2Log.Client.NamedPipe in '..\X2Log.Client.NamedPipe.pas',
X2Log.Client.Base in '..\X2Log.Client.Base.pas',
X2Log.Observer.Event in '..\X2Log.Observer.Event.pas',
X2Log.Constants in '..\X2Log.Constants.pas',
X2Log.Observer.Custom in '..\X2Log.Observer.Custom.pas';
{$R *.res}

5
NamedPipeClient/X2LogNamedPipeClient.dproj
View File

@ -87,6 +87,11 @@
<FormType>dfm</FormType>
</DCCReference>
<DCCReference Include="..\X2Log.Intf.pas"/>
<DCCReference Include="..\X2Log.Client.NamedPipe.pas"/>
<DCCReference Include="..\X2Log.Client.Base.pas"/>
<DCCReference Include="..\X2Log.Observer.Event.pas"/>
<DCCReference Include="..\X2Log.Constants.pas"/>
<DCCReference Include="..\X2Log.Observer.Custom.pas"/>
<BuildConfiguration Include="Release">
<Key>Cfg_2</Key>
<CfgParent>Base</CfgParent>

229
NamedPipeClient/source/MainFrm.pas
View File

@ -2,8 +2,12 @@ unit MainFrm;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
System.Classes,
Vcl.Controls,
Vcl.Forms,
Vcl.StdCtrls,
X2Log.Intf;
type
@ -12,232 +16,35 @@ type
procedure FormCreate(Sender: TObject);
private
FClientThread: TThread;
procedure DoMessage(Sender: TObject; Msg: TStream);
FClient: IX2LogObservable;
FObserver: IX2LogObserver;
protected
procedure DoLog(Sender: TObject; Level: TX2LogLevel; const Msg, Details: string);
end;
implementation
uses
System.SyncObjs,
X2Log.Intf;
X2Log.Constants,
X2Log.Client.NamedPipe,
X2Log.Observer.Event;
{$R *.dfm}
type
TClientMessageEvent = procedure(Sender: TObject; Msg: TStream) of object;
TClientThread = class(TThread)
private
FTerminateEvent: TEvent;
FPipe: THandle;
FOverlappedRead: TOverlapped;
FReadBuffer: array[0..4095] of Byte;
FMessage: TMemoryStream;
FOnMessage: TClientMessageEvent;
protected
procedure Execute; override;
procedure TerminatedSet; override;
procedure ReadMessage;
procedure HandleMessage;
procedure DoMessage;
public
constructor Create;
destructor Destroy; override;
property OnMessage: TClientMessageEvent read FOnMessage write FOnMessage;
end;
{ TMainForm }
procedure TMainForm.FormCreate(Sender: TObject);
begin
FClientThread := TClientThread.Create;
(FClientThread as TClientThread).OnMessage := DoMessage;
FClient := TX2LogNamedPipeClient.Create('X2LogTest');
FObserver := TX2LogEventObserver.Create(DoLog);
FClient.Attach(FObserver);
end;
procedure TMainForm.DoMessage(Sender: TObject; Msg: TStream);
function ReadString: string;
var
size: Cardinal;
begin
Msg.ReadBuffer(size, SizeOf(cardinal));
if size > 0 then
begin
SetLength(Result, size);
Msg.ReadBuffer(Result[1], size * SizeOf(Char));
end else
Result := '';
end;
var
level: TX2LogLevel;
logMsg: string;
detail: string;
procedure TMainForm.DoLog(Sender: TObject; Level: TX2LogLevel; const Msg, Details: string);
begin
Msg.ReadBuffer(level, SizeOf(TX2LogLevel));
logMsg := ReadString;
detail := ReadString;
mmoLog.Lines.Add(logMsg + ' (' + detail + ')');
end;
const
FILE_WRITE_ATTRIBUTES = $0100;
{ TClientThread }
constructor TClientThread.Create;
begin
FTerminateEvent := TEvent.Create(nil, True, False, '');
FMessage := TMemoryStream.Create;
inherited Create(False);
end;
destructor TClientThread.Destroy;
begin
FreeAndNil(FMessage);
FreeAndNil(FTerminateEvent);
inherited Destroy;
end;
procedure TClientThread.Execute;
var
mode: Cardinal;
readEvent: TEvent;
events: array[0..1] of THandle;
waitResult: Cardinal;
bytesTransferred: Cardinal;
begin
while not Terminated do
begin
FPipe := CreateFile('\\.\pipe\X2LogTest', GENERIC_READ or FILE_WRITE_ATTRIBUTES,
0, nil, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0);
if FPipe = INVALID_HANDLE_VALUE then
begin
if GetLastError = ERROR_PIPE_BUSY then
begin
if not WaitNamedPipe('\\.\pipe\X2LogTest', 5000) then
exit;
end else
RaiseLastOSError;
end else
break;
end;
if Terminated then
exit;
mode := PIPE_READMODE_MESSAGE;
if not SetNamedPipeHandleState(FPipe, mode, nil, nil) then
exit;
readEvent := TEvent.Create(nil, False, False, '');
events[0] := FTerminateEvent.Handle;
events[1] := readEvent.Handle;
FOverlappedRead.hEvent := readEvent.Handle;
ReadMessage;
while not Terminated do
begin
waitResult := WaitForMultipleObjects(Length(events), @events, False, INFINITE);
case waitResult of
WAIT_OBJECT_0:
{ Terminated }
break;
WAIT_OBJECT_0 + 1:
{ Read event completed }
if GetOverlappedResult(FPipe, FOverlappedRead, bytesTransferred, False) then
begin
FMessage.WriteBuffer(FReadBuffer[0], bytesTransferred);
HandleMessage;
ReadMessage;
end else
begin
if GetLastError = ERROR_MORE_DATA then
begin
FMessage.WriteBuffer(FReadBuffer[0], bytesTransferred);
ReadMessage;
end else
break;
end;
end;
end;
CloseHandle(FPipe);
end;
procedure TClientThread.ReadMessage;
var
bytesRead: Cardinal;
lastError: Cardinal;
begin
while True do
begin
if ReadFile(FPipe, FReadBuffer, SizeOf(FReadBuffer), bytesRead, @FOverlappedRead) then
begin
{ Immediate result }
FMessage.WriteBuffer(FReadBuffer[0], bytesRead);
HandleMessage;
end else
begin
{ More data, pending I/O or an actual error }
lastError := GetLastError;
if lastError = ERROR_IO_PENDING then
break
else if lastError = ERROR_MORE_DATA then
FMessage.WriteBuffer(FReadBuffer[0], SizeOf(FReadBuffer))
else
break;
end;
end;
end;
procedure TClientThread.HandleMessage;
begin
if FMessage.Size > 0 then
begin
FMessage.Position := 0;
Synchronize(DoMessage);
FMessage.Clear;
end;
end;
procedure TClientThread.TerminatedSet;
begin
inherited TerminatedSet;
FTerminateEvent.SetEvent;
end;
procedure TClientThread.DoMessage;
begin
if Assigned(FOnMessage) then
FOnMessage(Self, FMessage);
mmoLog.Lines.Add(GetLogLevelText(Level) + ': ' + Msg + ' (' + Details + ')');
end;
end.

4
Test/X2LogTest.dpr
View File

@ -19,7 +19,9 @@ uses
X2Log.Observer.NamedPipe in '..\X2Log.Observer.NamedPipe.pas',
X2Log.Observer.CustomThreaded in '..\X2Log.Observer.CustomThreaded.pas',
X2Log.Observer.MonitorForm in '..\X2Log.Observer.MonitorForm.pas' {X2LogObserverMonitorForm},
X2Log.Global in '..\X2Log.Global.pas';
X2Log.Global in '..\X2Log.Global.pas',
X2Log.Client.NamedPipe in '..\X2Log.Client.NamedPipe.pas',
X2Log.Client.Base in '..\X2Log.Client.Base.pas';
{$R *.res}

2
Test/X2LogTest.dproj
View File

@ -190,6 +190,8 @@
<FormType>dfm</FormType>
</DCCReference>
<DCCReference Include="..\X2Log.Global.pas"/>
<DCCReference Include="..\X2Log.Client.NamedPipe.pas"/>
<DCCReference Include="..\X2Log.Client.Base.pas"/>
<BuildConfiguration Include="Debug">
<Key>Cfg_2</Key>
<CfgParent>Base</CfgParent>

BIN
Test/resources/ObserverActive.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.2 KiB

BIN
Test/resources/ObserverInactive.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.2 KiB

221
Test/source/MainFrm.dfm
View File

@ -26,41 +26,148 @@ object MainForm: TMainForm
Margins.Top = 8
Margins.Right = 8
Margins.Bottom = 8
ActivePage = tsEvent
ActivePage = tsFile
Align = alClient
Images = ilsObservers
TabOrder = 0
OnChange = pcObserversChange
ExplicitTop = 113
ExplicitHeight = 361
object tsEvent: TTabSheet
Caption = 'Event Observer '
ExplicitHeight = 333
object mmoEvent: TMemo
AlignWithMargins = True
Left = 8
Top = 8
Top = 40
Width = 571
Height = 261
Height = 229
Margins.Left = 8
Margins.Top = 8
Margins.Top = 40
Margins.Right = 8
Margins.Bottom = 8
Align = alClient
ReadOnly = True
ScrollBars = ssVertical
TabOrder = 0
ExplicitHeight = 317
ExplicitTop = 41
end
object btnEventStart: TButton
Left = 8
Top = 8
Width = 75
Height = 25
Caption = 'Start'
TabOrder = 1
OnClick = btnEventStartClick
end
object btnEventStop: TButton
Left = 89
Top = 8
Width = 75
Height = 25
Caption = 'Stop'
TabOrder = 2
OnClick = btnEventStopClick
end
end
object tsFile: TTabSheet
Caption = 'File Observer'
ImageIndex = 1
ExplicitHeight = 333
ExplicitLeft = -108
ExplicitTop = -5
object lblFilename: TLabel
Left = 12
Top = 64
Width = 46
Height = 13
Caption = 'Filename:'
end
object btnFileStart: TButton
Left = 8
Top = 8
Width = 75
Height = 25
Caption = 'Start'
TabOrder = 0
OnClick = btnFileStartClick
end
object btnFileStop: TButton
Left = 89
Top = 8
Width = 75
Height = 25
Caption = 'Stop'
TabOrder = 1
OnClick = btnFileStopClick
end
object edtFilename: TEdit
Left = 88
Top = 61
Width = 489
Height = 21
TabOrder = 2
Text = 'X2LogTest\Test.log'
end
object rbProgramData: TRadioButton
Left = 88
Top = 88
Width = 113
Height = 17
Caption = 'Program Data'
Checked = True
TabOrder = 3
TabStop = True
end
object rbUserData: TRadioButton
Left = 88
Top = 111
Width = 113
Height = 17
Caption = 'User Application Data'
TabOrder = 4
end
object rbAbsolute: TRadioButton
Left = 88
Top = 134
Width = 113
Height = 17
Caption = 'Absolute path'
TabOrder = 5
end
end
object tsNamedPipe: TTabSheet
Caption = 'Named Pipe Observer'
ImageIndex = 2
ExplicitHeight = 333
ExplicitLeft = 0
ExplicitTop = 30
object lblPipeName: TLabel
Left = 12
Top = 64
Width = 53
Height = 13
Caption = 'Pipe name:'
end
object btnNamedPipeStart: TButton
Left = 8
Top = 8
Width = 75
Height = 25
Caption = 'Start'
TabOrder = 0
OnClick = btnNamedPipeStartClick
end
object btnNamedPipeStop: TButton
Left = 89
Top = 8
Width = 75
Height = 25
Caption = 'Stop'
TabOrder = 1
OnClick = btnNamedPipeStopClick
end
object edtPipeName: TEdit
Left = 88
Top = 61
Width = 489
Height = 21
TabOrder = 2
Text = 'X2LogTest'
end
end
end
object pnlButtons: TPanel
@ -200,4 +307,92 @@ object MainForm: TMainForm
OnClick = btnLogClick
end
end
object ilsObservers: TImageList
Height = 12
Width = 12
Left = 552
Top = 176
Bitmap = {
494C01010200140020000C000C00FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600
0000000000003600000028000000300000000C00000001002000000000000009
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000000000000000000000000000788D
F400274DEA00274DEA001C41E5001C37D8007380E20000000000000000000000
000000000000000000000000000074C97D001EA7330017A83000139F29001695
220071BB76000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000004C6EF7003C6B
FF003C6BFF003162FF003162FF002855F5001B3EE1003C4FD700000000000000
0000000000000000000043BE560028C1520026BF4F0026BF4F0021BA44001BB0
3800139F290039A0400000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000819BFD004876FF004674
FF004674FF004674FF003C6BFF003162FF002D5CFC001B3EE1007380E2000000
0000000000007CD58B0030C9610030C961002FC85F0028C1520028C1520026BF
4F001BB03800139F290071BB7600000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000517EFE005484FF005484
FF005484FF004B79FF004674FF004674FF003162FF002855F5001D38D8000000
00000000000046CC6A0038D16B0038D16B0038D16B0036CE690030C9610028C1
520028C152001BB0380016952200000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000749EFF006295FF006295
FF006295FF005B8CFF005484FF004674FF004674FF003162FF001C41E5000000
0000000000005CDC850041DA740041DA740041DA740038D16B0038D16B0030C9
610028C1520021BA4400139F2900000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000089B1FF0071A6FF0071A6
FF006DA2FF006599FF005B8CFF005484FF004674FF003C6BFF00274DEA000000
0000000000006EE5940049E27C0049E27C0049E27C0041DA740041DA740038D1
6B0030C9610028C152001BB03800000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000000000007CA7FF008EBFFF0080B8
FF007AB2FF0071A6FF006295FF005B8CFF004674FF003C6BFF00294EEA000000
00000000000067E28D0067EE940053EC860053EC860049E27C0041DA740038D1
6B0030C9610028C152001EA73300000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000000000009FBCFF00ADD6FF0091CB
FF0080B8FF007AB2FF006A9FFF005D90FF004B79FF004674FF00788DF4000000
00000000000095EAAF008AF6AE0061F5920056EF89004EE7810046DF790041DA
740036CE69002CC55A0074C97D00000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000000000000000000089B1FF00B4DF
FF0091CBFF007AB2FF006DA2FF006295FF00517EFE004876FF00000000000000
0000000000000000000079E99D008EFBB20068F396004FE9830047E07A003DD6
700036CE690046C45D0000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000000000000000000000000000A3C0
FF0089B1FF008EBFFF007CA7FF005484FF00819BFD0000000000000000000000
000000000000000000000000000099EEB3006EE5940070E998005CE1870048D1
6F0081DB93000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000424D3E000000000000003E000000
28000000300000000C0000000100010000000000600000000000000000000000
000000000000000000000000FFFFFF00FFFFFF0000000000E07E070000000000
C03C030000000000801801000000000080180100000000008018010000000000
801801000000000080180100000000008018010000000000C03C030000000000
E07E070000000000FFFFFF000000000000000000000000000000000000000000
000000000000}
end
end

145
Test/source/MainFrm.pas
View File

@ -9,7 +9,7 @@ uses
Vcl.Forms,
Vcl.StdCtrls,
X2Log.Intf;
X2Log.Intf, Vcl.ImgList;
type
@ -32,22 +32,41 @@ type
btnInfo: TButton;
btnWarning: TButton;
btnError: TButton;
btnEventStart: TButton;
btnEventStop: TButton;
ilsObservers: TImageList;
btnFileStart: TButton;
btnFileStop: TButton;
btnNamedPipeStart: TButton;
btnNamedPipeStop: TButton;
edtFilename: TEdit;
lblFilename: TLabel;
rbProgramData: TRadioButton;
rbUserData: TRadioButton;
rbAbsolute: TRadioButton;
edtPipeName: TEdit;
lblPipeName: TLabel;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure pcObserversChange(Sender: TObject);
procedure btnCloseClick(Sender: TObject);
procedure btnLogClick(Sender: TObject);
procedure edtExceptionKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure edtMessageKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure btnExceptionClick(Sender: TObject);
procedure btnMonitorFormClick(Sender: TObject);
procedure btnEventStartClick(Sender: TObject);
procedure btnEventStopClick(Sender: TObject);
procedure btnFileStartClick(Sender: TObject);
procedure btnFileStopClick(Sender: TObject);
procedure btnNamedPipeStartClick(Sender: TObject);
procedure btnNamedPipeStopClick(Sender: TObject);
private
FLog: IX2Log;
FObserver: IX2LogObserver;
FEventObserver: IX2LogObserver;
FFileObserver: IX2LogObserver;
FNamedPipeObserver: IX2LogObserver;
protected
procedure InitObserver;
procedure DoLog(Sender: TObject; Level: TX2LogLevel; const Msg, Details: string);
end;
@ -90,7 +109,6 @@ begin
FLog.SetExceptionStrategy(TX2LogmadExceptExceptionStrategy.Create);
pcObservers.ActivePageIndex := 0;
InitObserver;
end;
@ -100,37 +118,6 @@ begin
end;
procedure TMainForm.InitObserver;
var
activePage: TTabSheet;
begin
if Assigned(FObserver) then
begin
FLog.Detach(FObserver);
FObserver := nil;
end;
activePage := pcObservers.ActivePage;
if activePage = tsEvent then
FObserver := TX2LogEventObserver.Create(DoLog)
else if activePage = tsFile then
FObserver := TX2LogFileObserver.CreateInProgramData('X2LogTest\Test.log');
if activePage = tsNamedPipe then
begin
FObserver := TX2LogNamedPipeObserver.Create('X2LogTest');
end else
begin
end;
if Assigned(FObserver) then
FLog.Attach(FObserver);
end;
procedure TMainForm.DoLog(Sender: TObject; Level: TX2LogLevel; const Msg, Details: string);
begin
mmoEvent.Lines.Add(GetLogLevelText(Level) + ': ' + Msg + ' (' + Details + ')');
@ -156,12 +143,6 @@ begin
end;
end;
procedure TMainForm.pcObserversChange(Sender: TObject);
begin
InitObserver;
end;
procedure TMainForm.btnCloseClick(Sender: TObject);
begin
Close;
@ -199,4 +180,82 @@ begin
TX2LogObserverMonitorForm.ShowInstance(FLog);
end;
procedure TMainForm.btnEventStartClick(Sender: TObject);
begin
if not Assigned(FEventObserver) then
begin
FEventObserver := TX2LogEventObserver.Create(DoLog);
FLog.Attach(FEventObserver);
tsEvent.ImageIndex := 1;
end;
end;
procedure TMainForm.btnEventStopClick(Sender: TObject);
begin
if Assigned(FEventObserver) then
begin
FLog.Detach(FEventObserver);
FEventObserver := nil;
tsEvent.ImageIndex := 0;
end;
end;
procedure TMainForm.btnFileStartClick(Sender: TObject);
begin
if not Assigned(FFileObserver) then
begin
if rbProgramData.Checked then
FFileObserver := TX2LogFileObserver.CreateInProgramData(edtFilename.Text)
else if rbUserData.Checked then
FFileObserver := TX2LogFileObserver.CreateInUserAppData(edtFilename.Text)
else
FFileObserver := TX2LogFileObserver.Create(edtFilename.Text);
FLog.Attach(FFileObserver);
tsFile.ImageIndex := 1;
end;
end;
procedure TMainForm.btnFileStopClick(Sender: TObject);
begin
if Assigned(FFileObserver) then
begin
FLog.Detach(FFileObserver);
FFileObserver := nil;
tsFile.ImageIndex := 0;
end;
end;
procedure TMainForm.btnNamedPipeStartClick(Sender: TObject);
begin
if not Assigned(FNamedPipeObserver) then
begin
FNamedPipeObserver := TX2LogNamedPipeObserver.Create(edtPipeName.Text);
FLog.Attach(FNamedPipeObserver);
tsNamedPipe.ImageIndex := 1;
end;
end;
procedure TMainForm.btnNamedPipeStopClick(Sender: TObject);
begin
if Assigned(FNamedPipeObserver) then
begin
FLog.Detach(FNamedPipeObserver);
FNamedPipeObserver := nil;
tsNamedPipe.ImageIndex := 0;
end;
end;
end.

76
X2Log.Client.Base.pas Normal file
View File

@ -0,0 +1,76 @@
unit X2Log.Client.Base;
interface
uses
System.Classes,
System.Generics.Collections,
X2Log.Intf;
type
TX2LogBaseClient = class(TInterfacedPersistent, IX2LogObservable)
private
FObservers: TList<IX2LogObserver>;
protected
property Observers: TList<IX2LogObserver> read FObservers;
public
constructor Create;
destructor Destroy; override;
{ IX2LogBase }
procedure Log(ALevel: TX2LogLevel; const AMessage: string; const ADetails: string = ''); virtual;
{ IX2LogObservable }
procedure Attach(AObserver: IX2LogObserver);
procedure Detach(AObserver: IX2LogObserver);
end;
implementation
uses
System.SysUtils;
{ TX2LogBaseClient }
constructor TX2LogBaseClient.Create;
begin
inherited Create;
FObservers := TList<IX2LogObserver>.Create;
end;
destructor TX2LogBaseClient.Destroy;
begin
FreeAndNil(FObservers);
inherited Destroy;
end;
procedure TX2LogBaseClient.Attach(AObserver: IX2LogObserver);
begin
{ Explicit cast ensures we're getting the same pointer in Attach and Detach
if, for example, the implementing interface is a descendant of IX2LogObserver }
Observers.Add(AObserver as IX2LogObserver);
end;
procedure TX2LogBaseClient.Detach(AObserver: IX2LogObserver);
begin
Observers.Remove(AObserver as IX2LogObserver);
end;
procedure TX2LogBaseClient.Log(ALevel: TX2LogLevel; const AMessage, ADetails: string);
var
observer: IX2LogObserver;
begin
for observer in Observers do
observer.Log(ALevel, AMessage, ADetails);
end;
end.

310
X2Log.Client.NamedPipe.pas Normal file
View File

@ -0,0 +1,310 @@
unit X2Log.Client.NamedPipe;
interface
uses
System.Classes,
System.Generics.Collections,
X2Log.Intf,
X2Log.Client.Base;
type
TX2LogNamedPipeClient = class(TX2LogBaseClient, IX2LogBase)
private
FWorkerThread: TThread;
protected
property WorkerThread: TThread read FWorkerThread;
public
constructor Create(const APipeName: string);
end;
implementation
uses
System.SyncObjs,
System.SysUtils,
Winapi.Windows;
type
TX2LogNamedPipeClientWorkerThread = class(TThread)
private
FLog: IX2LogBase;
FPipeName: string;
FTerminateEvent: TEvent;
FPipeHandle: THandle;
FOverlappedRead: TOverlapped;
FReadBuffer: array[0..4095] of Byte;
FMessageData: TMemoryStream;
protected
procedure Execute; override;
procedure TerminatedSet; override;
procedure ConnectPipe;
procedure ReadPipe;
procedure ClosePipe;
procedure ReadMessage;
procedure HandleMessage;
property Log: IX2LogBase read FLog;
property PipeName: string read FPipeName;
property TerminateEvent: TEvent read FTerminateEvent;
property PipeHandle: THandle read FPipeHandle;
property MessageData: TMemoryStream read FMessageData;
public
constructor Create(ALog: IX2LogBase; const APipeName: string);
end;
const
PipeNamePrefix = '\\.\pipe\';
TimeoutBusyPipe = 5000;
TimeoutNoPipe = 1000;
ClearBufferTreshold = 4096;
{ TX2LogNamedPipeClient }
constructor TX2LogNamedPipeClient.Create(const APipeName: string);
begin
inherited Create;
FWorkerThread := TX2LogNamedPipeClientWorkerThread.Create(Self, APipeName);
end;
{ TX2LogNamedPipeClientWorkerThread }
constructor TX2LogNamedPipeClientWorkerThread.Create(ALog: IX2LogBase; const APipeName: string);
begin
FTerminateEvent := TEvent.Create(nil, True, False, '');
FMessageData := TMemoryStream.Create;
FLog := ALog;
FPipeName := APipeName;
inherited Create(False);
end;
procedure TX2LogNamedPipeClientWorkerThread.Execute;
begin
FPipeHandle := INVALID_HANDLE_VALUE;
try
while not Terminated do
begin
ConnectPipe;
if not Terminated then
ReadPipe;
end;
finally
ClosePipe;
end;
end;
procedure TX2LogNamedPipeClientWorkerThread.TerminatedSet;
begin
inherited TerminatedSet;
TerminateEvent.SetEvent;
end;
procedure TX2LogNamedPipeClientWorkerThread.ConnectPipe;
var
lastError: Cardinal;
mode: Cardinal;
begin
while not Terminated do
begin
FPipeHandle := CreateFile(PChar(PipeNamePrefix + PipeName), GENERIC_READ or FILE_WRITE_ATTRIBUTES,
0, nil, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0);
if PipeHandle = INVALID_HANDLE_VALUE then
begin
lastError := GetLastError;
case lastError of
ERROR_PIPE_BUSY:
{ Pipe exists but is connecting to another client, wait for a new slot }
WaitNamedPipe(PChar(PipeNamePrefix + PipeName), TimeoutBusyPipe);
ERROR_FILE_NOT_FOUND:
{ Pipe does not exist, try again later }
WaitForSingleObject(TerminateEvent.Handle, TimeoutNoPipe);
else
RaiseLastOSError;
end;
end else
begin
{ Change to message mode }
mode := PIPE_READMODE_MESSAGE;
if not SetNamedPipeHandleState(PipeHandle, mode, nil, nil) then
RaiseLastOSError;
break;
end;
end;
end;
procedure TX2LogNamedPipeClientWorkerThread.ReadPipe;
var
readEvent: TEvent;
events: array[0..1] of THandle;
waitResult: Cardinal;
bytesTransferred: Cardinal;
begin
readEvent := TEvent.Create(nil, False, False, '');
events[0] := TerminateEvent.Handle;
events[1] := readEvent.Handle;
FOverlappedRead.hEvent := readEvent.Handle;
ReadMessage;
while (not Terminated) and (PipeHandle <> INVALID_HANDLE_VALUE) do
begin
waitResult := WaitForMultipleObjects(Length(events), @events, False, INFINITE);
case waitResult of
WAIT_OBJECT_0:
{ Terminated }
break;
WAIT_OBJECT_0 + 1:
{ Read event completed }
if GetOverlappedResult(PipeHandle, FOverlappedRead, bytesTransferred, False) then
begin
MessageData.WriteBuffer(FReadBuffer[0], bytesTransferred);
HandleMessage;
ReadMessage;
end else
begin
if GetLastError = ERROR_MORE_DATA then
begin
MessageData.WriteBuffer(FReadBuffer[0], bytesTransferred);
ReadMessage;
end else
begin
ClosePipe;
break;
end;
end;
end;
end;
end;
procedure TX2LogNamedPipeClientWorkerThread.ClosePipe;
begin
if PipeHandle <> INVALID_HANDLE_VALUE then
begin
CloseHandle(PipeHandle);
FPipeHandle := INVALID_HANDLE_VALUE;
end;
end;
procedure TX2LogNamedPipeClientWorkerThread.ReadMessage;
var
bytesRead: Cardinal;
lastError: Cardinal;
begin
while PipeHandle <> INVALID_HANDLE_VALUE do
begin
if ReadFile(PipeHandle, FReadBuffer, SizeOf(FReadBuffer), bytesRead, @FOverlappedRead) then
begin
{ Immediate result }
MessageData.WriteBuffer(FReadBuffer[0], bytesRead);
HandleMessage;
end else
begin
{ More data, pending I/O or an actual error }
lastError := GetLastError;
if lastError = ERROR_IO_PENDING then
break
else if lastError = ERROR_MORE_DATA then
MessageData.WriteBuffer(FReadBuffer[0], SizeOf(FReadBuffer))
else
begin
ClosePipe;
break;
end;
end;
end;
end;
procedure TX2LogNamedPipeClientWorkerThread.HandleMessage;
function ReadString: WideString;
var
size: Cardinal;
begin
MessageData.ReadBuffer(size, SizeOf(cardinal));
if size > 0 then
begin
SetLength(Result, size);
MessageData.ReadBuffer(Result[1], size * SizeOf(WideChar));
end else
Result := '';
end;
var
header: TX2LogMessageHeaderV1;
headerDiff: Integer;
msg: string;
details: string;
begin
if MessageData.Size > 0 then
begin
try
MessageData.Position := 0;
MessageData.ReadBuffer(header, SizeOf(header));
if header.ID <> X2LogMessageHeader then
raise EReadError.Create('Invalid header ID');
headerDiff := SizeOf(header) - header.Size;
if headerDiff > 0 then
begin
{ A larger, most likely newer version, header }
MessageData.Seek(headerDiff, soFromCurrent)
end else if headerDiff < 0 then
raise EReadError.Create('Header too small');
msg := ReadString;
details := ReadString;
Log.Log(header.Level, msg, details);
except
on E:EReadError do
ClosePipe;
on E:Exception do
RaiseLastOSError;
end;
if MessageData.Size > ClearBufferTreshold then
MessageData.Clear
else
MessageData.Position := 0;
end;
end;
end.

2
X2Log.Global.pas
View File

@ -22,7 +22,7 @@ type
class procedure SetExceptionStrategy(AStrategy: IX2LogExceptionStrategy);
{ Facade for IX2LogMethods }
{ Facade for IX2LogBase }
class procedure Log(ALevel: TX2LogLevel; const AMessage: string; const ADetails: string = '');
class procedure Verbose(const AMessage: string; const ADetails: string = '');

36
X2Log.Intf.pas
View File

@ -8,13 +8,13 @@ type
TX2LogLevel = (Verbose, Info, Warning, Error);
IX2LogMethods = interface
IX2LogBase = interface
['{1949E8DC-6DC5-43DC-B678-55CF8274E79D}']
procedure Log(ALevel: TX2LogLevel; const AMessage: string; const ADetails: string = '');
end;
IX2LogObserver = interface(IX2LogMethods)
IX2LogObserver = interface(IX2LogBase)
['{CBC5C18E-84EE-43F4-8DBE-C66D06FCDE74}']
end;
@ -25,11 +25,15 @@ type
end;
IX2Log = interface(IX2LogMethods)
['{A6FF38F9-EDA8-4C76-9C95-2C0317560D78}']
IX2LogObservable = interface(IX2LogBase)
['{50B47D5D-11E4-40E0-BBC4-8BA70697C1F9}']
procedure Attach(AObserver: IX2LogObserver);
procedure Detach(AObserver: IX2LogObserver);
end;
IX2Log = interface(IX2LogObservable)
['{A6FF38F9-EDA8-4C76-9C95-2C0317560D78}']
procedure SetExceptionStrategy(AStrategy: IX2LogExceptionStrategy);
procedure Verbose(const AMessage: string; const ADetails: string = '');
@ -40,6 +44,30 @@ type
end;
TX2LogMessageHeaderV1 = packed record
ID: Word;
Version: Byte;
Size: Word;
Level: TX2LogLevel;
{
Payload:
MessageLength: Cardinal
Message: WideString
DetailsLength: Cardinal
Details: WideString
}
end;
TX2LogMessageHeader = TX2LogMessageHeaderV1;
const
X2LogMessageHeader: Word = $B258;
X2LogMessageVersion: Byte = 1;
implementation
end.

2
X2Log.Observer.CustomThreaded.pas
View File

@ -174,6 +174,8 @@ var
entry: TX2LogQueueEntry;
begin
NameThreadForDebugging('TX2LogObserverWorkerThread');
Setup;
try
while not Terminated do

20
X2Log.Observer.Event.pas
View File

@ -13,23 +13,30 @@ type
TX2LogEventObserver = class(TX2LogCustomObserver)
private
FOnLog: TX2LogEvent;
FRunInMainThread: Boolean;
protected
procedure DoLog(ALevel: TX2LogLevel; const AMessage: string; const ADetails: string = ''); override;
public
constructor Create(ALogLevels: TX2LogLevels = X2LogLevelsDefault); overload;
constructor Create(AOnLog: TX2LogEvent; ALogLevels: TX2LogLevels = X2LogLevelsDefault); overload;
property RunInMainThread: Boolean read FRunInMainThread write FRunInMainThread default True;
property OnLog: TX2LogEvent read FOnLog write FOnLog;
end;
implementation
uses
System.Classes;
{ TX2LogEventObserver }
constructor TX2LogEventObserver.Create(ALogLevels: TX2LogLevels);
begin
inherited Create(ALogLevels);
FRunInMainThread := True;
end;
@ -44,7 +51,18 @@ end;
procedure TX2LogEventObserver.DoLog(ALevel: TX2LogLevel; const AMessage, ADetails: string);
begin
if Assigned(FOnLog) then
FOnLog(Self, ALevel, AMessage, ADetails);
begin
if RunInMainThread then
begin
TThread.Queue(nil,
procedure
begin
if Assigned(FOnLog) then
FOnLog(Self, ALevel, AMessage, ADetails);
end);
end else
FOnLog(Self, ALevel, AMessage, ADetails);
end;
end;
end.

7
X2Log.Observer.MonitorForm.dfm
View File

@ -35,7 +35,6 @@ object X2LogObserverMonitorForm: TX2LogObserverMonitorForm
Align = alRight
BevelOuter = bvNone
TabOrder = 0
ExplicitHeight = 500
object tbDetails: TToolBar
Left = 0
Top = 0
@ -69,7 +68,6 @@ object X2LogObserverMonitorForm: TX2LogObserverMonitorForm
BevelKind = bkFlat
BevelOuter = bvNone
TabOrder = 1
ExplicitHeight = 478
object HeaderControl1: THeaderControl
Left = 0
Top = 0
@ -101,7 +99,6 @@ object X2LogObserverMonitorForm: TX2LogObserverMonitorForm
ReadOnly = True
ScrollBars = ssBoth
TabOrder = 1
ExplicitHeight = 457
end
end
end
@ -113,7 +110,6 @@ object X2LogObserverMonitorForm: TX2LogObserverMonitorForm
Align = alClient
BevelOuter = bvNone
TabOrder = 1
ExplicitHeight = 500
object vstLog: TVirtualStringTree
Left = 0
Top = 22
@ -138,7 +134,6 @@ object X2LogObserverMonitorForm: TX2LogObserverMonitorForm
OnGetImageIndex = vstLogGetImageIndex
OnGetHint = vstLogGetHint
OnInitNode = vstLogInitNode
ExplicitHeight = 478
Columns = <
item
Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coShowDropMark, coVisible, coAllowFocus]
@ -199,7 +194,7 @@ object X2LogObserverMonitorForm: TX2LogObserverMonitorForm
Left = 584
Top = 48
Bitmap = {
494C0101090040007C0010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600
494C010109004000800010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600
0000000000003600000028000000400000003000000001002000000000000030
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000

90
X2Log.Observer.NamedPipe.pas
View File

@ -20,6 +20,7 @@ type
implementation
uses
System.Classes,
System.Generics.Collections,
System.SyncObjs,
System.SysUtils,
@ -35,15 +36,18 @@ type
TX2LogNamedPipeClient = class(TObject)
private
FOverlapped: TOverlapped;
FPipe: THandle;
FPipeHandle: THandle;
FState: TX2LogNamedPipeClientState;
FOverlappedEvent: TEvent;
FWriteQueue: TObjectQueue<TX2LogQueueEntry>;
FWriteBuffer: Pointer;
FWriteBufferSize: Integer;
FWriteBuffer: TMemoryStream;
protected
function DoSend(AEntry: TX2LogQueueEntry): Boolean;
procedure ClearWriteBuffer;
property PipeHandle: THandle read FPipeHandle;
property WriteBuffer: TMemoryStream read FWriteBuffer;
property WriteQueue: TObjectQueue<TX2LogQueueEntry> read FWriteQueue;
public
constructor Create(APipe: THandle);
destructor Destroy; override;
@ -53,7 +57,7 @@ type
procedure Disconnect;
property Pipe: THandle read FPipe;
property Pipe: THandle read FPipeHandle;
property Overlapped: TOverlapped read FOverlapped;
property OverlappedEvent: TEvent read FOverlappedEvent;
property State: TX2LogNamedPipeClientState read FState write FState;
@ -65,7 +69,6 @@ type
FClients: TObjectList<TX2LogNamedPipeClient>;
FPipeName: string;
protected
procedure WaitForEntry; override;
procedure ProcessEntry(AEntry: TX2LogQueueEntry); override;
procedure ProcessClientEvent(AClientIndex: Integer);
@ -103,7 +106,7 @@ constructor TX2LogNamedPipeClient.Create(APipe: THandle);
begin
inherited Create;
FPipe := APipe;
FPipeHandle := APipe;
FState := Listening;
FOverlappedEvent := TEvent.Create(nil, False, False, '');
@ -115,8 +118,8 @@ destructor TX2LogNamedPipeClient.Destroy;
begin
FreeAndNil(FOverlappedEvent);
if FPipe <> INVALID_HANDLE_VALUE then
DisconnectNamedPipe(FPipe);
if PipeHandle <> INVALID_HANDLE_VALUE then
DisconnectNamedPipe(PipeHandle);
ClearWriteBuffer;
@ -126,14 +129,14 @@ end;
procedure TX2LogNamedPipeClient.Send(AEntry: TX2LogQueueEntry);
begin
if not Assigned(FWriteBuffer) then
if not Assigned(WriteBuffer) then
DoSend(AEntry)
else
begin
if not Assigned(FWriteQueue) then
if not Assigned(WriteQueue) then
FWriteQueue := TObjectQueue<TX2LogQueueEntry>.Create(True);
FWriteQueue.Enqueue(TX2LogQueueEntry.Create(AEntry));
WriteQueue.Enqueue(TX2LogQueueEntry.Create(AEntry));
end;
end;
@ -145,15 +148,18 @@ var
begin
ClearWriteBuffer;
while FWriteQueue.Count > 0 do
if Assigned(WriteQueue) then
begin
entry := FWriteQueue.Extract;
try
{ Returns False when IO is pending }
if not DoSend(entry) then
break;
finally
FreeAndNil(entry);
while WriteQueue.Count > 0 do
begin
entry := WriteQueue.Extract;
try
{ Returns False when IO is pending }
if not DoSend(entry) then
break;
finally
FreeAndNil(entry);
end;
end;
end;
end;
@ -161,55 +167,49 @@ end;
procedure TX2LogNamedPipeClient.Disconnect;
begin
if FPipe <> INVALID_HANDLE_VALUE then
if PipeHandle <> INVALID_HANDLE_VALUE then
begin
CancelIo(FPipe);
DisconnectNamedPipe(FPipe);
CancelIo(PipeHandle);
DisconnectNamedPipe(PipeHandle);
FPipe := INVALID_HANDLE_VALUE;
FPipeHandle := INVALID_HANDLE_VALUE;
end;
end;
function TX2LogNamedPipeClient.DoSend(AEntry: TX2LogQueueEntry): Boolean;
procedure AppendToBuffer(var APointer: PByte; const ASource; ASize: Cardinal); overload; inline;
begin
Move(ASource, APointer^, ASize);
Inc(APointer, ASize);
end;
procedure AppendToBuffer(var APointer: PByte; const ASource: string); overload; inline;
procedure WriteString(const ASource: WideString);
var
sourceLength: Cardinal;
begin
sourceLength := Length(ASource);
AppendToBuffer(APointer, sourceLength, SizeOf(Cardinal));
AppendToBuffer(APointer, PChar(ASource)^, sourceLength * SizeOf(Char));
WriteBuffer.WriteBuffer(sourceLength, SizeOf(Cardinal));
WriteBuffer.WriteBuffer(PWideChar(ASource)^, sourceLength * SizeOf(WideChar));
end;
var
header: TX2LogMessageHeader;
bytesWritten: Cardinal;
bufferPointer: PByte;
lastError: Cardinal;
begin
ClearWriteBuffer;
FWriteBufferSize := SizeOf(TX2LogLevel) +
SizeOf(Cardinal) + (Length(AEntry.Message) * SizeOf(Char)) +
SizeOf(Cardinal) + (Length(AEntry.Details) * SizeOf(Char));
FWriteBuffer := TMemoryStream.Create;
GetMem(FWriteBuffer, FWriteBufferSize);
header.ID := X2LogMessageHeader;
header.Version := X2LogMessageVersion;
header.Size := SizeOf(header);
header.Level := AEntry.Level;
bufferPointer := FWriteBuffer;
AppendToBuffer(bufferPointer, AEntry.Level, SizeOf(TX2LogLevel));
AppendToBuffer(bufferPointer, AEntry.Message);
AppendToBuffer(bufferPointer, AEntry.Details);
WriteBuffer.WriteBuffer(header, SizeOf(header));
WriteString(AEntry.Message);
WriteString(AEntry.Details);
Result := WriteFile(Pipe, FWriteBuffer^, FWriteBufferSize, bytesWritten, @Overlapped);
Result := WriteFile(Pipe, WriteBuffer.Memory^, WriteBuffer.Size, bytesWritten, @Overlapped);
if not Result then
begin
lastError := GetLastError;
@ -233,11 +233,7 @@ end;
procedure TX2LogNamedPipeClient.ClearWriteBuffer;
begin
if Assigned(FWriteBuffer) then
begin
FreeMem(FWriteBuffer, FWriteBufferSize);
FWriteBuffer := nil;
end;
FreeAndNil(FWriteBuffer);
end;

47
X2Log.pas
View File

@ -6,30 +6,22 @@ uses
System.Generics.Collections,
System.SysUtils,
X2Log.Intf;
X2Log.Intf,
X2Log.Client.Base;
type
TX2Log = class(TInterfacedObject, IX2Log, IX2LogMethods)
TX2Log = class(TX2LogBaseClient, IX2Log)
private
FExceptionStrategy: IX2LogExceptionStrategy;
FObservers: TList<IX2LogObserver>;
private
property ExceptionStrategy: IX2LogExceptionStrategy read FExceptionStrategy;
property Observers: TList<IX2LogObserver> read FObservers;
public
constructor Create;
destructor Destroy; override;
{ IX2Log }
procedure Attach(AObserver: IX2LogObserver);
procedure Detach(AObserver: IX2LogObserver);
procedure SetExceptionStrategy(AStrategy: IX2LogExceptionStrategy);
{ IX2LogMethods }
procedure Log(ALevel: TX2LogLevel; const AMessage: string; const ADetails: string = '');
procedure Verbose(const AMessage: string; const ADetails: string = '');
procedure Info(const AMessage: string; const ADetails: string = '');
procedure Warning(const AMessage: string; const ADetails: string = '');
@ -48,33 +40,10 @@ constructor TX2Log.Create;
begin
inherited Create;
FObservers := TList<IX2LogObserver>.Create;
SetExceptionStrategy(nil);
end;
destructor TX2Log.Destroy;
begin
FreeAndNil(FObservers);
inherited Destroy;
end;
procedure TX2Log.Attach(AObserver: IX2LogObserver);
begin
{ Explicit cast ensures we're getting the same pointer in Attach and Detach
if, for example, the implementing interface is a descendant of IX2LogObserver }
Observers.Add(AObserver as IX2LogObserver);
end;
procedure TX2Log.Detach(AObserver: IX2LogObserver);
begin
Observers.Remove(AObserver as IX2LogObserver);
end;
procedure TX2Log.SetExceptionStrategy(AStrategy: IX2LogExceptionStrategy);
begin
if Assigned(AStrategy) then
@ -84,16 +53,6 @@ begin
end;
procedure TX2Log.Log(ALevel: TX2LogLevel; const AMessage, ADetails: string);
var
observer: IX2LogObserver;
begin
for observer in Observers do
observer.Log(ALevel, AMessage, ADetails);
end;
procedure TX2Log.Verbose(const AMessage, ADetails: string);
begin
Log(TX2LogLevel.Verbose, AMessage, ADetails);