diff --git a/NamedPipeClient/X2LogNamedPipeClient.dpr b/NamedPipeClient/X2LogNamedPipeClient.dpr new file mode 100644 index 0000000..5503192 --- /dev/null +++ b/NamedPipeClient/X2LogNamedPipeClient.dpr @@ -0,0 +1,18 @@ +program X2LogNamedPipeClient; + +uses + Vcl.Forms, + MainFrm in 'source\MainFrm.pas' {MainForm}, + X2Log.Intf in '..\X2Log.Intf.pas'; + +{$R *.res} + +var + MainForm: TMainForm; + +begin + Application.Initialize; + Application.MainFormOnTaskbar := True; + Application.CreateForm(TMainForm, MainForm); + Application.Run; +end. diff --git a/NamedPipeClient/X2LogNamedPipeClient.dproj b/NamedPipeClient/X2LogNamedPipeClient.dproj new file mode 100644 index 0000000..eb8409d --- /dev/null +++ b/NamedPipeClient/X2LogNamedPipeClient.dproj @@ -0,0 +1,178 @@ + + + {883FC03C-9DB1-43A5-8053-5C920FDBCCAC} + 13.4 + VCL + X2LogNamedPipeClient.dpr + True + Debug + Win32 + 1 + Application + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + fmx;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;DataSnapProviderClient;DbxCommonDriver;dbxcds;DBXOracleDriver;CustomIPTransport;dsnap;fmxase;IndyCore;inetdbxpress;IPIndyImpl;bindcompfmx;rtl;dbrtl;DbxClientDriver;bindcomp;inetdb;xmlrtl;ibxpress;IndyProtocols;DBXMySQLDriver;soaprtl;bindengine;DBXInformixDriver;DBXFirebirdDriver;inet;fmxobj;DBXSybaseASADriver;fmxdae;dbexpress;DataSnapIndy10ServerTransport;$(DCC_UsePackage) + $(BDS)\bin\delphi_PROJECTICON.ico + System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + 1043 + None + lib + bin + + + dxdborRS16;cxLibraryRS16;dxLayoutControlRS16;dxPScxPivotGridLnkRS16;dxCoreRS16;cxExportRS16;dxBarRS16;cxSpreadSheetRS16;cxTreeListdxBarPopupMenuRS16;TeeDB;dxDBXServerModeRS16;dxPsPrVwAdvRS16;vclib;dxPSCoreRS16;cxPivotGridOLAPRS16;dxPScxTLLnkRS16;dxPScxGridLnkRS16;cxPageControlRS16;dxRibbonRS16;DBXSybaseASEDriver;vclimg;cxTreeListRS16;dxComnRS16;vcldb;dxADOServerModeRS16;vcldsnap;dxBarExtDBItemsRS16;DBXDb2Driver;vcl;DBXMSSQLDriver;cxDataRS16;cxBarEditItemRS16;dxDockingRS16;dxPSDBTeeChartRS16;cxPageControldxBarPopupMenuRS16;webdsnap;dxBarExtItemsRS16;dxPSLnksRS16;dxPSTeeChartRS16;adortl;dxPSdxLCLnkRS16;dxorgcRS16;dxWizardControlRS16;dxPScxExtCommonRS16;dxNavBarRS16;dxPSdxDBOCLnkRS16;cxSchedulerTreeBrowserRS16;Tee;DBXOdbcDriver;dxdbtrRS16;dxPScxSSLnkRS16;dxPScxCommonRS16;dxmdsRS16;dxPSPrVwRibbonRS16;cxGridRS16;cxEditorsRS16;TeeUI;vclactnband;dxServerModeRS16;bindcompvcl;cxPivotGridRS16;dxPScxSchedulerLnkRS16;dxPSdxDBTVLnkRS16;vclie;cxSchedulerRibbonStyleEventEditorRS16;cxSchedulerRS16;vcltouch;websnap;VclSmp;dxTabbedMDIRS16;DataSnapConnectors;dxPSdxOCLnkRS16;dsnapcon;dxPSdxFCLnkRS16;dxThemeRS16;dxPScxPCProdRS16;vclx;dxFlowChartRS16;dxGDIPlusRS16;dxBarDBNavRS16;$(DCC_UsePackage) + + + dxdborRS16;cxLibraryRS16;dxLayoutControlRS16;dxPScxPivotGridLnkRS16;dxCoreRS16;cxExportRS16;dxBarRS16;cxSpreadSheetRS16;cxTreeListdxBarPopupMenuRS16;TeeDB;dxDBXServerModeRS16;dxPsPrVwAdvRS16;vclib;inetdbbde;dxPSCoreRS16;cxPivotGridOLAPRS16;dxPScxTLLnkRS16;dxPScxGridLnkRS16;cxPageControlRS16;dxRibbonRS16;DBXSybaseASEDriver;vclimg;fmi;cxTreeListRS16;dxComnRS16;vcldb;dxADOServerModeRS16;vcldsnap;dxBarExtDBItemsRS16;X2CLGL;DBXDb2Driver;vcl;CloudService;DBXMSSQLDriver;CodeSiteExpressPkg;FmxTeeUI;cxDataRS16;cxBarEditItemRS16;dxDockingRS16;dxPSDBTeeChartRS16;cxPageControldxBarPopupMenuRS16;cxSchedulerGridRS16;webdsnap;X2CLMB;dxBarExtItemsRS16;dxPSLnksRS16;OmniThreadLibraryRuntimeXE2;dxtrmdRS16;dxPSTeeChartRS16;adortl;dxPSdxLCLnkRS16;madBasic_;dxorgcRS16;dxWizardControlRS16;dxPScxExtCommonRS16;vcldbx;dxNavBarRS16;dxPSdxDBOCLnkRS16;cxSchedulerTreeBrowserRS16;Tee;DBXOdbcDriver;dxdbtrRS16;madDisAsm_;svnui;dxPScxSSLnkRS16;dxPScxCommonRS16;dxmdsRS16;dxPSPrVwRibbonRS16;cxPivotGridChartRS16;cxGridRS16;cxEditorsRS16;FMXTee;TeeUI;vclactnband;dxServerModeRS16;bindcompvcl;cxPivotGridRS16;dxPScxSchedulerLnkRS16;dxPSdxDBTVLnkRS16;vclie;cxSchedulerRibbonStyleEventEditorRS16;cxSchedulerRS16;madExcept_;vcltouch;websnap;VclSmp;dxTabbedMDIRS16;DataSnapConnectors;dxPSdxOCLnkRS16;dsnapcon;dxPSdxFCLnkRS16;dxThemeRS16;dxPScxPCProdRS16;vclx;svn;dxFlowChartRS16;bdertl;VirtualTreesR;dxGDIPlusRS16;dxBarDBNavRS16;$(DCC_UsePackage) + true + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + 1033 + $(BDS)\bin\default_app.manifest + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + + + DEBUG;$(DCC_Define) + false + true + true + true + + + true + 1033 + false + + + false + RELEASE;$(DCC_Define) + 0 + false + + + + MainSource + + +
MainForm
+ dfm + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1043 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + X2LogNamedPipeClient.dpr + + + JVCL Application and Form Components + JVCL Band Objects + JVCL BDE Components + JVCL Non-Visual Components + JVCL Visual Controls + JVCL Core Components + JVCL Encryption and Compression + JVCL Custom Controls + JVCL Database Components + JVCL Dialog Components + JVCL Docking Components + JVCL DotNet Controls + JVCL Globus Components + JVCL HMI Controls + JVCL Jans Components + JVCL Managed Threads + JVCL Multimedia and Image Components + JVCL Network Components + JVCL Page Style Components + JVCL Interpreter Components + JVCL Plugin Components + JVCL Print Preview Components + JVCL Runtime Design Components + JVCL Standard Controls + JVCL System Components + JVCL Time Framework + JVCL Wizard + JVCL XP Controls + + + + + False + True + + + 12 + + + + diff --git a/NamedPipeClient/X2LogNamedPipeClient.res b/NamedPipeClient/X2LogNamedPipeClient.res new file mode 100644 index 0000000..c287ee9 Binary files /dev/null and b/NamedPipeClient/X2LogNamedPipeClient.res differ diff --git a/NamedPipeClient/source/MainFrm.dfm b/NamedPipeClient/source/MainFrm.dfm new file mode 100644 index 0000000..b9ae385 --- /dev/null +++ b/NamedPipeClient/source/MainFrm.dfm @@ -0,0 +1,27 @@ +object MainForm: TMainForm + Left = 0 + Top = 0 + Caption = 'X'#178'Log Named Pipe Client' + ClientHeight = 443 + ClientWidth = 552 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 96 + TextHeight = 13 + object mmoLog: TMemo + Left = 0 + Top = 0 + Width = 552 + Height = 443 + Align = alClient + ReadOnly = True + ScrollBars = ssVertical + TabOrder = 0 + end +end diff --git a/NamedPipeClient/source/MainFrm.pas b/NamedPipeClient/source/MainFrm.pas new file mode 100644 index 0000000..e0d0f07 --- /dev/null +++ b/NamedPipeClient/source/MainFrm.pas @@ -0,0 +1,243 @@ +unit MainFrm; + +interface +uses + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls; + + +type + TMainForm = class(TForm) + mmoLog: TMemo; + + procedure FormCreate(Sender: TObject); + private + FClientThread: TThread; + + procedure DoMessage(Sender: TObject; Msg: TStream); + end; + + +implementation +uses + System.SyncObjs, + + X2Log.Intf; + + +{$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; +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; + +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); +end; + +end. diff --git a/Test/X2LogTest.dpr b/Test/X2LogTest.dpr new file mode 100644 index 0000000..ff3104f --- /dev/null +++ b/Test/X2LogTest.dpr @@ -0,0 +1,27 @@ +program X2LogTest; + +uses + Forms, + MainFrm in 'source\MainFrm.pas' {MainForm}, + X2Log.Intf in '..\X2Log.Intf.pas', + X2Log in '..\X2Log.pas', + X2Log.Observer.Event in '..\X2Log.Observer.Event.pas', + X2Log.Observer.Custom in '..\X2Log.Observer.Custom.pas', + X2Log.Exception.Default in '..\X2Log.Exception.Default.pas', + X2Log.Exception.madExcept in '..\X2Log.Exception.madExcept.pas', + X2Log.Observer.LogFile in '..\X2Log.Observer.LogFile.pas', + X2Log.Constants in '..\X2Log.Constants.pas', + X2Log.Observer.NamedPipe in '..\X2Log.Observer.NamedPipe.pas', + X2Log.Observer.CustomThreaded in '..\X2Log.Observer.CustomThreaded.pas'; + +{$R *.res} + +var + MainForm: TMainForm; + +begin + Application.Initialize; + Application.MainFormOnTaskbar := True; + Application.CreateForm(TMainForm, MainForm); + Application.Run; +end. diff --git a/Test/X2LogTest.dproj b/Test/X2LogTest.dproj new file mode 100644 index 0000000..b34f1bf --- /dev/null +++ b/Test/X2LogTest.dproj @@ -0,0 +1,201 @@ + + + {e601c684-e576-44d0-b94c-9a32de0c82c4} + Debug + DCC32 + X2LogTest.exe + X2LogTest.dpr + VCL + 13.4 + True + Debug + Win32 + 1 + Application + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + $(BDS)\bin\delphi_PROJECTICON.ico + bin + None + lib + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + 1043 + + + X2LogTest_Icon.ico + $(BDS)\bin\default_app.manifest + + + true + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + 1033 + $(BDS)\bin\default_app.manifest + + + 7.0 + False + False + 0 + RELEASE;$(DCC_Define) + + + true + $(BDS)\bin\default_app.manifest + 1033 + + + 7.0 + DEBUG;$(DCC_Define) + + + $(BDS)\bin\default_app.manifest + true + 1033 + + + Delphi.Personality.12 + + + + + False + True + False + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1043 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + JVCL Application and Form Components + JVCL Band Objects + JVCL BDE Components + JVCL Non-Visual Components + JVCL Visual Controls + JVCL Core Components + JVCL Encryption and Compression + JVCL Custom Controls + JVCL Database Components + JVCL Dialog Components + JVCL Docking Components + JVCL DotNet Controls + JVCL Globus Components + JVCL HMI Controls + JVCL Jans Components + JVCL Managed Threads + JVCL Multimedia and Image Components + JVCL Network Components + JVCL Page Style Components + JVCL Interpreter Components + JVCL Plugin Components + JVCL Print Preview Components + JVCL Runtime Design Components + JVCL Standard Controls + JVCL System Components + JVCL Time Framework + JVCL Wizard + JVCL XP Controls + + + X2LogTest.dpr + + + + False + True + + + 12 + + + + MainSource + + +
MainForm
+ + + + + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + + + diff --git a/Test/X2LogTest.res b/Test/X2LogTest.res new file mode 100644 index 0000000..c287ee9 Binary files /dev/null and b/Test/X2LogTest.res differ diff --git a/Test/source/MainFrm.dfm b/Test/source/MainFrm.dfm new file mode 100644 index 0000000..672e37f --- /dev/null +++ b/Test/source/MainFrm.dfm @@ -0,0 +1,155 @@ +object MainForm: TMainForm + Left = 0 + Top = 0 + Caption = 'X'#178'Log Test' + ClientHeight = 515 + ClientWidth = 611 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + Position = poScreenCenter + OnCreate = FormCreate + OnDestroy = FormDestroy + PixelsPerInch = 96 + TextHeight = 13 + object pcObservers: TPageControl + AlignWithMargins = True + Left = 8 + Top = 113 + Width = 595 + Height = 361 + Margins.Left = 8 + Margins.Top = 8 + Margins.Right = 8 + Margins.Bottom = 8 + ActivePage = tsNamedPipe + Align = alClient + TabOrder = 0 + OnChange = pcObserversChange + object tsEvent: TTabSheet + Caption = 'Event Observer ' + object mmoEvent: TMemo + AlignWithMargins = True + Left = 8 + Top = 8 + Width = 571 + Height = 317 + Margins.Left = 8 + Margins.Top = 8 + Margins.Right = 8 + Margins.Bottom = 8 + Align = alClient + ReadOnly = True + ScrollBars = ssVertical + TabOrder = 0 + end + end + object tsFile: TTabSheet + Caption = 'File Observer' + ImageIndex = 1 + end + object tsNamedPipe: TTabSheet + Caption = 'Named Pipe Observer' + ImageIndex = 2 + end + end + object pnlButtons: TPanel + AlignWithMargins = True + Left = 8 + Top = 482 + Width = 595 + Height = 25 + Margins.Left = 8 + Margins.Top = 0 + Margins.Right = 8 + Margins.Bottom = 8 + Align = alBottom + BevelOuter = bvNone + TabOrder = 1 + object btnClose: TButton + Left = 520 + Top = 0 + Width = 75 + Height = 25 + Align = alRight + Cancel = True + Caption = 'Close' + TabOrder = 0 + end + end + object GroupBox1: TGroupBox + AlignWithMargins = True + Left = 8 + Top = 8 + Width = 595 + Height = 97 + Margins.Left = 8 + Margins.Top = 8 + Margins.Right = 8 + Margins.Bottom = 0 + Align = alTop + Caption = ' Dispatch ' + TabOrder = 2 + DesignSize = ( + 595 + 97) + object lblMessage: TLabel + Left = 16 + Top = 32 + Width = 46 + Height = 13 + Caption = 'Message:' + end + object lblException: TLabel + Left = 16 + Top = 59 + Width = 51 + Height = 13 + Caption = 'Exception:' + end + object edtMessage: TEdit + Left = 92 + Top = 29 + Width = 402 + Height = 21 + Anchors = [akLeft, akTop, akRight] + TabOrder = 0 + Text = 'Hello world!' + OnKeyDown = edtMessageKeyDown + end + object btnSend: TButton + Left = 500 + Top = 29 + Width = 75 + Height = 21 + Anchors = [akLeft, akTop, akRight] + Caption = '&Send' + TabOrder = 1 + OnClick = btnSendClick + end + object edtException: TEdit + Left = 92 + Top = 56 + Width = 402 + Height = 21 + Anchors = [akLeft, akTop, akRight] + TabOrder = 2 + Text = 'Horrible things are happening.' + OnKeyDown = edtExceptionKeyDown + end + object btnException: TButton + Left = 500 + Top = 56 + Width = 75 + Height = 21 + Anchors = [akLeft, akTop, akRight] + Caption = '&Send' + TabOrder = 3 + OnClick = btnExceptionClick + end + end +end diff --git a/Test/source/MainFrm.pas b/Test/source/MainFrm.pas new file mode 100644 index 0000000..9eb5948 --- /dev/null +++ b/Test/source/MainFrm.pas @@ -0,0 +1,167 @@ +unit MainFrm; + +interface +uses + System.Classes, + Vcl.ComCtrls, + Vcl.Controls, + Vcl.ExtCtrls, + Vcl.Forms, + Vcl.StdCtrls, + + X2Log.Intf; + + +type + TMainForm = class(TForm) + btnClose: TButton; + btnSend: TButton; + edtMessage: TEdit; + GroupBox1: TGroupBox; + lblMessage: TLabel; + mmoEvent: TMemo; + pcObservers: TPageControl; + pnlButtons: TPanel; + tsEvent: TTabSheet; + tsFile: TTabSheet; + lblException: TLabel; + edtException: TEdit; + btnException: TButton; + tsNamedPipe: TTabSheet; + + procedure FormCreate(Sender: TObject); + procedure FormDestroy(Sender: TObject); + procedure pcObserversChange(Sender: TObject); + procedure btnSendClick(Sender: TObject); + procedure edtExceptionKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); + procedure edtMessageKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); + procedure btnExceptionClick(Sender: TObject); + private + FLog: IX2Log; + FObserver: IX2LogObserver; + protected + procedure InitObserver; + + procedure DoLog(Sender: TObject; Level: TX2LogLevel; const Msg, Details: string); + end; + + +implementation +uses + System.SysUtils, + Winapi.Windows, + + X2Log, + X2Log.Constants, + X2Log.Exception.madExcept, + X2Log.Observer.Event, + X2Log.Observer.LogFile, + X2Log.Observer.NamedPipe; + + +{$R *.dfm} + + +{ TMainForm } +procedure TMainForm.FormCreate(Sender: TObject); +begin + SetLogResourceString(@LogLevelVerbose, 'Uitgebreid'); + SetLogResourceString(@LogLevelInfo, 'Informatie'); + SetLogResourceString(@LogLevelWarning, 'Waarschuwing'); + SetLogResourceString(@LogLevelError, 'Fout'); + + FLog := TX2Log.Create; + FLog.SetExceptionStrategy(TX2LogmadExceptExceptionStrategy.Create); + + pcObservers.ActivePageIndex := 0; + InitObserver; +end; + + +procedure TMainForm.FormDestroy(Sender: TObject); +begin + FLog := nil; +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 + ')'); +end; + + +procedure TMainForm.edtMessageKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); +begin + if Key = VK_RETURN then + begin + btnException.Click; + Key := 0; + end; +end; + + +procedure TMainForm.edtExceptionKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); +begin + if Key = VK_RETURN then + begin + btnException.Click; + Key := 0; + end; +end; + +procedure TMainForm.pcObserversChange(Sender: TObject); +begin + InitObserver; +end; + + +procedure TMainForm.btnSendClick(Sender: TObject); +begin + FLog.Info(edtMessage.Text); +end; + + +procedure TMainForm.btnExceptionClick(Sender: TObject); +begin + try + { Throw an actual exception, don't just create it, to allow + strategies like madExcept to do their stack trace } + raise EAbort.Create(edtException.Text); + except + on E:Exception do + FLog.Exception(E); + end; +end; + +end. diff --git a/X2Log.Constants.pas b/X2Log.Constants.pas new file mode 100644 index 0000000..ffc0546 --- /dev/null +++ b/X2Log.Constants.pas @@ -0,0 +1,89 @@ +unit X2Log.Constants; + +interface +uses + X2Log.Intf; + + +resourcestring + LogLevelVerbose = 'Verbose'; + LogLevelInfo = 'Info'; + LogLevelWarning = 'Warning'; + LogLevelError = 'Error'; + + + { + X2Log.Observer.LogFile + } + + { Date format used to determine the file name of detail files } + LogFileNameDateFormat = 'ddmmyyyy_hhnn'; + + { Date format used in log files } + LogFileLineDateFormat = 'dd-mm-yy hh:nn'; + + { The text added to the message if details are stored externally } + LogFileLineDetails = ' (details: %s)'; + + + + function GetLogLevelText(ALogLevel: TX2LogLevel): string; + + function GetLogResourceString(AResourceString: Pointer): string; + procedure SetLogResourceString(AResourceString: Pointer; const AValue: string); + + +implementation +uses + System.Generics.Collections, + System.SysUtils; + + +var + LogResourceStringMap: TDictionary; + + + +function GetLogLevelText(ALogLevel: TX2LogLevel): string; +begin + case ALogLevel of + TX2LogLevel.Verbose: Result := GetLogResourceString(@LogLevelVerbose); + TX2LogLevel.Info: Result := GetLogResourceString(@LogLevelInfo); + TX2LogLevel.Warning: Result := GetLogResourceString(@LogLevelWarning); + TX2LogLevel.Error: Result := GetLogResourceString(@LogLevelError); + end; +end; + + +function GetLogResourceString(AResourceString: Pointer): string; +begin + TMonitor.Enter(LogResourceStringMap); + try + if LogResourceStringMap.ContainsKey(AResourceString) then + Result := LogResourceStringMap[AResourceString] + else + Result := LoadResString(AResourceString); + finally + TMonitor.Exit(LogResourceStringMap); + end; +end; + + +procedure SetLogResourceString(AResourceString: Pointer; const AValue: string); +begin + TMonitor.Enter(LogResourceStringMap); + try + LogResourceStringMap.AddOrSetValue(AResourceString, AValue); + finally + TMonitor.Exit(LogResourceStringMap); + end; +end; + + +initialization + LogResourceStringMap := TDictionary.Create; + +finalization + FreeAndNil(LogResourceStringMap); + +end. diff --git a/X2Log.Exception.Default.pas b/X2Log.Exception.Default.pas new file mode 100644 index 0000000..2c1d5be --- /dev/null +++ b/X2Log.Exception.Default.pas @@ -0,0 +1,30 @@ +unit X2Log.Exception.Default; + +interface +uses + System.SysUtils, + + X2Log.Intf; + + +type + TX2LogDefaultExceptionStrategy = class(TInterfacedObject, IX2LogExceptionStrategy) + public + { IX2LogExceptionStrategy } + procedure Execute(AException: Exception; var AMessage: string; var ADetails: string); virtual; + end; + + +implementation + + +{ TX2LogDefaultExceptionStrategy } +procedure TX2LogDefaultExceptionStrategy.Execute(AException: Exception; var AMessage, ADetails: string); +begin + if Length(AMessage) > 0 then + AMessage := AMessage + ': '; + + AMessage := AMessage + AException.Message; +end; + +end. diff --git a/X2Log.Exception.madExcept.pas b/X2Log.Exception.madExcept.pas new file mode 100644 index 0000000..e15a9c5 --- /dev/null +++ b/X2Log.Exception.madExcept.pas @@ -0,0 +1,35 @@ +unit X2Log.Exception.madExcept; + +interface +uses + System.SysUtils, + + X2Log.Intf, + X2Log.Exception.Default; + + +type + TX2LogmadExceptExceptionStrategy = class(TX2LogDefaultExceptionStrategy) + public + { IX2LogExceptionStrategy } + procedure Execute(AException: Exception; var AMessage: string; var ADetails: string); override; + end; + + +implementation +uses + madExcept; + + +{ TX2LogmadExceptExceptionStrategy } +procedure TX2LogmadExceptExceptionStrategy.Execute(AException: Exception; var AMessage, ADetails: string); +begin + inherited Execute(AException, AMessage, ADetails); + + if Length(ADetails) > 0 then + ADetails := ADetails + #13#10; + + ADetails := ADetails + madExcept.CreateBugReport(etNormal, AException); +end; + +end. diff --git a/X2Log.Intf.pas b/X2Log.Intf.pas new file mode 100644 index 0000000..34ca6b4 --- /dev/null +++ b/X2Log.Intf.pas @@ -0,0 +1,45 @@ +unit X2Log.Intf; + +interface +uses + System.SysUtils; + +type + TX2LogLevel = (Verbose, Info, Warning, Error); + + + IX2LogMethods = interface + ['{1949E8DC-6DC5-43DC-B678-55CF8274E79D}'] + procedure Log(ALevel: TX2LogLevel; const AMessage: string; const ADetails: string = ''); + end; + + + IX2LogObserver = interface(IX2LogMethods) + ['{CBC5C18E-84EE-43F4-8DBE-C66D06FCDE74}'] + end; + + + IX2LogExceptionStrategy = interface + ['{C0B7950E-BE0A-4A21-A7C5-F8322FD4E205}'] + procedure Execute(AException: Exception; var AMessage: string; var ADetails: string); + end; + + + IX2Log = interface(IX2LogMethods) + ['{A6FF38F9-EDA8-4C76-9C95-2C0317560D78}'] + procedure Attach(AObserver: IX2LogObserver); + procedure Detach(AObserver: IX2LogObserver); + + procedure SetExceptionStrategy(AStrategy: IX2LogExceptionStrategy); + + procedure Verbose(const AMessage: string; const ADetails: string = ''); + procedure Info(const AMessage: string; const ADetails: string = ''); + procedure Warning(const AMessage: string; const ADetails: string = ''); + procedure Error(const AMessage: string; const ADetails: string = ''); + procedure Exception(AException: Exception; const AMessage: string = ''; const ADetails: string = ''); + end; + + +implementation + +end. diff --git a/X2Log.Observer.Custom.pas b/X2Log.Observer.Custom.pas new file mode 100644 index 0000000..2b8284f --- /dev/null +++ b/X2Log.Observer.Custom.pas @@ -0,0 +1,52 @@ +unit X2Log.Observer.Custom; + +interface +uses + Classes, + SysUtils, + + X2Log.Intf; + + +const + X2LogLevelsAll = [Low(TX2LogLevel)..High(TX2LogLevel)]; + X2LogLevelsDefault = X2LogLevelsAll - [Verbose]; + +type + TX2LogLevels = set of TX2LogLevel; + + TX2LogCustomObserver = class(TInterfacedObject, IX2LogObserver) + private + FLogLevels: TX2LogLevels; + protected + procedure DoLog(ALevel: TX2LogLevel; const AMessage: string; const ADetails: string = ''); virtual; abstract; + + { IX2LogObserver } + procedure Log(ALevel: TX2LogLevel; const AMessage: string; const ADetails: string = ''); virtual; + + property LogLevels: TX2LogLevels read FLogLevels; + public + constructor Create(ALogLevels: TX2LogLevels = X2LogLevelsDefault); + end; + + +implementation + + +{ TX2LogCustomObserver } +constructor TX2LogCustomObserver.Create(ALogLevels: TX2LogLevels); +begin + inherited Create; + + FLogLevels := ALogLevels; +end; + + +procedure TX2LogCustomObserver.Log(ALevel: TX2LogLevel; const AMessage, ADetails: string); +begin + if ALevel in LogLevels then + DoLog(ALevel, AMessage, ADetails); +end; + +end. + diff --git a/X2Log.Observer.CustomThreaded.pas b/X2Log.Observer.CustomThreaded.pas new file mode 100644 index 0000000..75a5419 --- /dev/null +++ b/X2Log.Observer.CustomThreaded.pas @@ -0,0 +1,235 @@ +unit X2Log.Observer.CustomThreaded; + +interface +uses + System.Classes, + System.Generics.Collections, + System.SyncObjs, + + X2Log.Intf, + X2Log.Observer.Custom; + + +type + TX2LogObserverWorkerThread = class; + + + TX2LogCustomThreadedObserver = class(TX2LogCustomObserver) + private + FWorkerThread: TX2LogObserverWorkerThread; + protected + function CreateWorkerThread: TX2LogObserverWorkerThread; virtual; abstract; + + procedure DoLog(ALevel: TX2LogLevel; const AMessage: string; const ADetails: string = ''); override; + + property WorkerThread: TX2LogObserverWorkerThread read FWorkerThread; + public + constructor Create(ALogLevels: TX2LogLevels = X2LogLevelsDefault); + destructor Destroy; override; + end; + + + TX2LogQueueEntry = class(TPersistent) + private + FDetails: string; + FLevel: TX2LogLevel; + FMessage: string; + public + constructor Create(ALevel: TX2LogLevel; const AMessage: string; const ADetails: string); overload; + constructor Create(AEntry: TX2LogQueueEntry); overload; + + procedure Assign(Source: TPersistent); override; + + property Details: string read FDetails; + property Level: TX2LogLevel read FLevel; + property Message: string read FMessage; + end; + + + TX2LogObserverWorkerThread = class(TThread) + private + FFileName: string; + FLogQueue: TObjectQueue; + FLogQueueSignal: TEvent; + protected + procedure Execute; override; + procedure TerminatedSet; override; + + procedure Setup; virtual; + procedure Cleanup; virtual; + + procedure WaitForEntry; virtual; + procedure ProcessEntry(AEntry: TX2LogQueueEntry); virtual; abstract; + + property FileName: string read FFileName; + property LogQueue: TObjectQueue read FLogQueue; + property LogQueueSignal: TEvent read FLogQueueSignal; + public + constructor Create; + destructor Destroy; override; + + procedure Log(ALevel: TX2LogLevel; const AMessage: string; const ADetails: string = ''); + end; + + +implementation +uses + System.SysUtils; + + +{ TX2LogCustomThreadedObserver } +constructor TX2LogCustomThreadedObserver.Create(ALogLevels: TX2LogLevels); +begin + inherited Create(ALogLevels); + + FWorkerThread := CreateWorkerThread; +end; + + +destructor TX2LogCustomThreadedObserver.Destroy; +begin + FreeAndNil(FWorkerThread); + + inherited Destroy; +end; + + +procedure TX2LogCustomThreadedObserver.DoLog(ALevel: TX2LogLevel; const AMessage, ADetails: string); +begin + WorkerThread.Log(ALevel, AMessage, ADetails); +end; + + + +{ TX2LogQueueEntry } +constructor TX2LogQueueEntry.Create(ALevel: TX2LogLevel; const AMessage: string; const ADetails: string); +begin + inherited Create; + + FLevel := ALevel; + FMessage := AMessage; + FDetails := ADetails; +end; + + +constructor TX2LogQueueEntry.Create(AEntry: TX2LogQueueEntry); +begin + inherited Create; + + Assign(AEntry); +end; + + +procedure TX2LogQueueEntry.Assign(Source: TPersistent); +var + entrySource: TX2LogQueueEntry; + +begin + if Source is TX2LogQueueEntry then + begin + entrySource := TX2LogQueueEntry(Source); + + FLevel := entrySource.Level; + FMessage := entrySource.Message; + FDetails := entrySource.Details; + end else + inherited Assign(Source); +end; + + +{ TX2LogObserverWorkerThread } +constructor TX2LogObserverWorkerThread.Create; +begin + FLogQueueSignal := TEvent.Create(nil, False, False, ''); + FLogQueue := TObjectQueue.Create(True); + + inherited Create(False); +end; + + +destructor TX2LogObserverWorkerThread.Destroy; +begin + inherited Destroy; + + FreeAndNil(FLogQueue); + FreeAndNil(FLogQueueSignal); +end; + + +procedure TX2LogObserverWorkerThread.Log(ALevel: TX2LogLevel; const AMessage, ADetails: string); +begin + TMonitor.Enter(LogQueue); + try + LogQueue.Enqueue(TX2LogQueueEntry.Create(ALevel, AMessage, ADetails)); + finally + TMonitor.Exit(LogQueue); + end; + + LogQueueSignal.SetEvent; +end; + + +procedure TX2LogObserverWorkerThread.Execute; +var + entry: TX2LogQueueEntry; + +begin + Setup; + try + while not Terminated do + begin + WaitForEntry; + + if Terminated then + break; + + entry := nil; + TMonitor.Enter(LogQueue); + try + if LogQueue.Count > 0 then + entry := LogQueue.Extract; + finally + TMonitor.Exit(LogQueue); + end; + + if Assigned(entry) then + try + ProcessEntry(entry); + finally + FreeAndNil(entry); + end; + end; + finally + Cleanup; + end; +end; + + +procedure TX2LogObserverWorkerThread.Setup; +begin +end; + + +procedure TX2LogObserverWorkerThread.Cleanup; +begin +end; + + +procedure TX2LogObserverWorkerThread.WaitForEntry; +begin + case LogQueueSignal.WaitFor(INFINITE) of + wrAbandoned, + wrError: + Terminate; + end; +end; + + +procedure TX2LogObserverWorkerThread.TerminatedSet; +begin + LogQueueSignal.SetEvent; + + inherited TerminatedSet; +end; + +end. diff --git a/X2Log.Observer.Event.pas b/X2Log.Observer.Event.pas new file mode 100644 index 0000000..fa7e297 --- /dev/null +++ b/X2Log.Observer.Event.pas @@ -0,0 +1,50 @@ +unit X2Log.Observer.Event; + +interface +uses + X2Log.Intf, + X2Log.Observer.Custom; + + +type + TX2LogEvent = procedure(Sender: TObject; Level: TX2LogLevel; const Msg, Details: string) of object; + + + TX2LogEventObserver = class(TX2LogCustomObserver) + private + FOnLog: TX2LogEvent; + 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 OnLog: TX2LogEvent read FOnLog write FOnLog; + end; + + +implementation + + +{ TX2LogEventObserver } +constructor TX2LogEventObserver.Create(ALogLevels: TX2LogLevels); +begin + inherited Create(ALogLevels); +end; + + +constructor TX2LogEventObserver.Create(AOnLog: TX2LogEvent; ALogLevels: TX2LogLevels); +begin + Create(ALogLevels); + + FOnLog := AOnLog; +end; + + +procedure TX2LogEventObserver.DoLog(ALevel: TX2LogLevel; const AMessage, ADetails: string); +begin + if Assigned(FOnLog) then + FOnLog(Self, ALevel, AMessage, ADetails); +end; + +end. diff --git a/X2Log.Observer.LogFile.pas b/X2Log.Observer.LogFile.pas new file mode 100644 index 0000000..7740ad4 --- /dev/null +++ b/X2Log.Observer.LogFile.pas @@ -0,0 +1,185 @@ +unit X2Log.Observer.LogFile; + +interface +uses + System.Classes, + System.Generics.Collections, + System.SyncObjs, + + X2Log.Intf, + X2Log.Observer.Custom, + X2Log.Observer.CustomThreaded; + + +type + TX2LogFileObserver = class(TX2LogCustomThreadedObserver) + private + FFileName: string; + protected + function CreateWorkerThread: TX2LogObserverWorkerThread; override; + public + constructor Create(const AFileName: string; ALogLevels: TX2LogLevels = X2LogLevelsDefault); + constructor CreateInProgramData(const AFileName: string; ALogLevels: TX2LogLevels = X2LogLevelsDefault); + constructor CreateInUserAppData(const AFileName: string; ALogLevels: TX2LogLevels = X2LogLevelsDefault); + end; + + +implementation +uses + System.IOUtils, + System.SysUtils, + System.Win.ComObj, + Winapi.SHFolder, + Winapi.Windows, + + X2Log.Constants; + + +type + TX2LogFileWorkerThread = class(TX2LogObserverWorkerThread) + private + FFileName: string; + protected + procedure ProcessEntry(AEntry: TX2LogQueueEntry); override; + + property FileName: string read FFileName; + public + constructor Create(const AFileName: string); + end; + + + +{ TX2LogFileObserver } +constructor TX2LogFileObserver.Create(const AFileName: string; ALogLevels: TX2LogLevels); +begin + FFileName := AFileName; + + inherited Create(ALogLevels); +end; + + +constructor TX2LogFileObserver.CreateInProgramData(const AFileName: string; ALogLevels: TX2LogLevels); +var + path: PWideChar; + +begin + GetMem(path, MAX_PATH); + try + OleCheck(SHGetFolderPath(0, CSIDL_COMMON_APPDATA, 0, SHGFP_TYPE_CURRENT, path)); + Create(IncludeTrailingPathDelimiter(path) + AFileName, ALogLevels); + finally + FreeMem(path); + end; +end; + + +constructor TX2LogFileObserver.CreateInUserAppData(const AFileName: string; ALogLevels: TX2LogLevels); +var + path: PWideChar; + +begin + GetMem(path, MAX_PATH); + try + OleCheck(SHGetFolderPath(0, CSIDL_APPDATA, 0, SHGFP_TYPE_CURRENT, path)); + Create(IncludeTrailingPathDelimiter(path) + AFileName, ALogLevels); + finally + FreeMem(path); + end; +end; + + +function TX2LogFileObserver.CreateWorkerThread: TX2LogObserverWorkerThread; +begin + Result := TX2LogFileWorkerThread.Create(FFileName); +end; + + +{ TX2LogFileWorkerThread } +constructor TX2LogFileWorkerThread.Create(const AFileName: string); +begin + FFileName := AFileName; + + inherited Create; +end; + + +procedure TX2LogFileWorkerThread.ProcessEntry(AEntry: TX2LogQueueEntry); +var + baseReportFileName: string; + errorMsg: string; + detailsExtension: string; + detailsFile: THandle; + detailsFileStream: THandleStream; + detailsWriter: TStreamWriter; + detailsFileName: string; + detailsNumber: Integer; + writer: TStreamWriter; + +begin + ForceDirectories(ExtractFilePath(FileName)); + errorMsg := AEntry.Message; + + if Length(AEntry.Details) > 0 then + begin + detailsExtension := ExtractFileExt(FileName); + baseReportFileName := ChangeFileExt(FileName, '_' + FormatDateTime(GetLogResourceString(@LogFileNameDateFormat), Now)); + detailsFileName := baseReportFileName + detailsExtension; + detailsNumber := 0; + + if ForceDirectories(ExtractFilePath(detailsFileName)) then + begin + repeat + { TFileStream lacks the ability to create a file only when it does not exist } + detailsFile := CreateFile(PChar(detailsFileName), GENERIC_READ or GENERIC_WRITE, + FILE_SHARE_READ or FILE_SHARE_WRITE, nil, CREATE_NEW, + FILE_ATTRIBUTE_NORMAL, 0); + + if detailsFile = INVALID_HANDLE_VALUE then + begin + if GetLastError = ERROR_FILE_EXISTS then + begin + { Generate a new file name } + Inc(detailsNumber); + detailsFileName := Format('%s_%d%s', [baseReportFileName, detailsNumber, + detailsExtension]); + end else + break; + end else + begin + { Details file succesfully generated } + try + detailsFileStream := THandleStream.Create(detailsFile); + try + detailsWriter := TStreamWriter.Create(detailsFileStream, TEncoding.ANSI); + try + detailsWriter.Write(AEntry.Details); + finally + FreeAndNil(detailsWriter); + end; + finally + FreeAndNil(detailsFileStream); + end; + finally + CloseHandle(detailsFile); + end; + + // ErrorLogs.Add(reportFileName); + + errorMsg := errorMsg + Format(GetLogResourceString(@LogFileLineDetails), [ExtractFileName(detailsFileName)]); + break; + end; + until False; + end; + end; + + { Append line to log file } + writer := TFile.AppendText(FileName); + try + writer.WriteLine('[' + FormatDateTime(GetLogResourceString(@LogFileLineDateFormat), Now) + '] ' + + GetLogLevelText(AEntry.Level) + ': ' + errorMsg); + finally + FreeAndNil(writer); + end; +end; + +end. diff --git a/X2Log.Observer.NamedPipe.pas b/X2Log.Observer.NamedPipe.pas new file mode 100644 index 0000000..39f96ad --- /dev/null +++ b/X2Log.Observer.NamedPipe.pas @@ -0,0 +1,422 @@ +unit X2Log.Observer.NamedPipe; + +interface +uses + X2Log.Intf, + X2Log.Observer.Custom, + X2Log.Observer.CustomThreaded; + + +type + TX2LogNamedPipeObserver = class(TX2LogCustomThreadedObserver) + private + FPipeName: string; + protected + function CreateWorkerThread: TX2LogObserverWorkerThread; override; + public + constructor Create(const APipeName: string; ALogLevels: TX2LogLevels = X2LogLevelsDefault); + end; + + +implementation +uses + System.Generics.Collections, + System.SyncObjs, + System.SysUtils, + Winapi.Windows; + + +type + EX2LogSilentException = class(Exception); + EX2LogPipeDisconnected = class(EX2LogSilentException); + + TX2LogNamedPipeClientState = (Listening, Connected, Writing); + + TX2LogNamedPipeClient = class(TObject) + private + FOverlapped: TOverlapped; + FPipe: THandle; + FState: TX2LogNamedPipeClientState; + FOverlappedEvent: TEvent; + FWriteQueue: TObjectQueue; + FWriteBuffer: Pointer; + FWriteBufferSize: Integer; + protected + function DoSend(AEntry: TX2LogQueueEntry): Boolean; + procedure ClearWriteBuffer; + public + constructor Create(APipe: THandle); + destructor Destroy; override; + + procedure Send(AEntry: TX2LogQueueEntry); + procedure SendNext; + + procedure Disconnect; + + property Pipe: THandle read FPipe; + property Overlapped: TOverlapped read FOverlapped; + property OverlappedEvent: TEvent read FOverlappedEvent; + property State: TX2LogNamedPipeClientState read FState write FState; + end; + + + TX2LogNamedPipeWorkerThread = class(TX2LogObserverWorkerThread) + private + FClients: TObjectList; + FPipeName: string; + protected + + procedure WaitForEntry; override; + procedure ProcessEntry(AEntry: TX2LogQueueEntry); override; + procedure ProcessClientEvent(AClientIndex: Integer); + + procedure AddListener; + procedure RemoveClient(AClientIndex: Integer); + procedure Setup; override; + procedure Cleanup; override; + + property Clients: TObjectList read FClients; + property PipeName: string read FPipeName; + public + constructor Create(const APipeName: string); + destructor Destroy; override; + end; + + +{ TX2LogNamedPipeObserver } +constructor TX2LogNamedPipeObserver.Create(const APipeName: string; ALogLevels: TX2LogLevels); +begin + FPipeName := APipeName; + + inherited Create(ALogLevels); +end; + + +function TX2LogNamedPipeObserver.CreateWorkerThread: TX2LogObserverWorkerThread; +begin + Result := TX2LogNamedPipeWorkerThread.Create(FPipeName); +end; + + +{ TX2LogNamedPipeClient } +constructor TX2LogNamedPipeClient.Create(APipe: THandle); +begin + inherited Create; + + FPipe := APipe; + FState := Listening; + + FOverlappedEvent := TEvent.Create(nil, False, False, ''); + FOverlapped.hEvent := FOverlappedEvent.Handle; +end; + + +destructor TX2LogNamedPipeClient.Destroy; +begin + FreeAndNil(FOverlappedEvent); + + if FPipe <> INVALID_HANDLE_VALUE then + DisconnectNamedPipe(FPipe); + + ClearWriteBuffer; + + inherited Destroy; +end; + + +procedure TX2LogNamedPipeClient.Send(AEntry: TX2LogQueueEntry); +begin + if not Assigned(FWriteBuffer) then + DoSend(AEntry) + else + begin + if not Assigned(FWriteQueue) then + FWriteQueue := TObjectQueue.Create(True); + + FWriteQueue.Enqueue(TX2LogQueueEntry.Create(AEntry)); + end; +end; + + +procedure TX2LogNamedPipeClient.SendNext; +var + entry: TX2LogQueueEntry; + +begin + ClearWriteBuffer; + + while FWriteQueue.Count > 0 do + begin + entry := FWriteQueue.Extract; + try + { Returns False when IO is pending } + if not DoSend(entry) then + break; + finally + FreeAndNil(entry); + end; + end; +end; + + +procedure TX2LogNamedPipeClient.Disconnect; +begin + if FPipe <> INVALID_HANDLE_VALUE then + begin + CancelIo(FPipe); + DisconnectNamedPipe(FPipe); + + FPipe := 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; + var + sourceLength: Cardinal; + + begin + sourceLength := Length(ASource); + AppendToBuffer(APointer, sourceLength, SizeOf(Cardinal)); + AppendToBuffer(APointer, PChar(ASource)^, sourceLength * SizeOf(Char)); + end; + + +var + 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)); + + GetMem(FWriteBuffer, FWriteBufferSize); + + bufferPointer := FWriteBuffer; + AppendToBuffer(bufferPointer, AEntry.Level, SizeOf(TX2LogLevel)); + AppendToBuffer(bufferPointer, AEntry.Message); + AppendToBuffer(bufferPointer, AEntry.Details); + + Result := WriteFile(Pipe, FWriteBuffer^, FWriteBufferSize, bytesWritten, @Overlapped); + if not Result then + begin + lastError := GetLastError; + if lastError in [ERROR_NO_DATA, ERROR_PIPE_NOT_CONNECTED] then + raise EX2LogPipeDisconnected.Create('Client disconnected'); + + if lastError = ERROR_IO_PENDING then + State := Writing + else + begin + ClearWriteBuffer; + RaiseLastOSError; + end; + end else + begin + ClearWriteBuffer; + State := Connected; + end; +end; + + +procedure TX2LogNamedPipeClient.ClearWriteBuffer; +begin + if Assigned(FWriteBuffer) then + begin + FreeMem(FWriteBuffer, FWriteBufferSize); + FWriteBuffer := nil; + end; +end; + + + +{ TX2LogNamedPipeWorkerThread } +constructor TX2LogNamedPipeWorkerThread.Create(const APipeName: string); +begin + FPipeName := APipeName; + FClients := TObjectList.Create(True); + + inherited Create; +end; + + +destructor TX2LogNamedPipeWorkerThread.Destroy; +begin + inherited Destroy; + + FreeAndNil(FClients); +end; + + +procedure TX2LogNamedPipeWorkerThread.Setup; +begin + inherited Setup; + + AddListener; +end; + + +procedure TX2LogNamedPipeWorkerThread.Cleanup; +var + client: TX2LogNamedPipeClient; + +begin + for client in Clients do + client.Disconnect; + + inherited Cleanup; +end; + + +procedure TX2LogNamedPipeWorkerThread.WaitForEntry; +var + eventHandles: array of THandle; + clientIndex: Integer; + waitResult: Cardinal; + +begin + repeat + SetLength(eventHandles, Clients.Count + 1); + for clientIndex := 0 to Pred(Clients.Count) do + eventHandles[clientIndex] := Clients[clientIndex].OverlappedEvent.Handle; + + eventHandles[Clients.Count] := LogQueueSignal.Handle; + + waitResult := WaitForMultipleObjects(Length(eventHandles), @eventHandles[0], False, INFINITE); + if waitResult in [WAIT_OBJECT_0..WAIT_OBJECT_0 + Pred(High(eventHandles))] then + begin + { Connect or write I/O completed } + clientIndex := waitResult - WAIT_OBJECT_0; + if (clientIndex >= 0) and (clientIndex < Clients.Count) then + ProcessClientEvent(clientIndex); + end else if waitResult = Cardinal(WAIT_OBJECT_0 + High(eventHandles)) then + begin + { Entry queued } + break; + end else if waitResult in [WAIT_ABANDONED_0..WAIT_ABANDONED_0 + High(eventHandles)] then + begin + { Client event abandoned } + clientIndex := waitResult - WAIT_ABANDONED_0; + if (clientIndex >= 0) and (clientIndex < Clients.Count) then + RemoveClient(clientIndex) + else if clientIndex = Clients.Count then + Terminate; + end else if waitResult = WAIT_FAILED then + RaiseLastOSError; + until False; +end; + + +procedure TX2LogNamedPipeWorkerThread.ProcessEntry(AEntry: TX2LogQueueEntry); +var + clientIndex: Integer; + client: TX2LogNamedPipeClient; + +begin + { Broadcast to connected clients } + for clientIndex := Pred(Clients.Count) downto 0 do + begin + client := Clients[clientIndex]; + + if client.State <> Listening then + try + client.Send(AEntry); + except + on E:EX2LogPipeDisconnected do + RemoveClient(clientIndex); + end; + end; +end; + + +procedure TX2LogNamedPipeWorkerThread.ProcessClientEvent(AClientIndex: Integer); +var + client: TX2LogNamedPipeClient; + bytesTransferred: Cardinal; + +begin + client := Clients[AClientIndex]; + + case client.State of + Listening: + { Client connected } + if GetOverlappedResult(client.Pipe, client.Overlapped, bytesTransferred, False) then + begin + client.State := Connected; + AddListener; + end else + RemoveClient(AClientIndex); + + Writing: + { Write operation completed } + if GetOverlappedResult(client.Pipe, client.Overlapped, bytesTransferred, False) and + (bytesTransferred > 0) then + begin + try + client.SendNext; + except + on E:EX2LogPipeDisconnected do + RemoveClient(AClientIndex); + end; + end else + RemoveClient(AClientIndex); + end; +end; + + +procedure TX2LogNamedPipeWorkerThread.AddListener; +const + BufferSize = 4096; + DefaultTimeout = 5000; + +var + pipe: THandle; + client: TX2LogNamedPipeClient; + +begin + pipe := CreateNamedPipe(PChar('\\.\pipe\' + PipeName), PIPE_ACCESS_OUTBOUND or FILE_FLAG_OVERLAPPED, + PIPE_TYPE_MESSAGE or PIPE_READMODE_MESSAGE or PIPE_WAIT, PIPE_UNLIMITED_INSTANCES, + BufferSize, BufferSize, DefaultTimeout, nil); + + if pipe <> INVALID_HANDLE_VALUE then + begin + client := TX2LogNamedPipeClient.Create(pipe); + + if not ConnectNamedPipe(client.Pipe, @client.Overlapped) then + begin + case GetLastError of + ERROR_IO_PENDING: + Clients.Add(client); + + ERROR_PIPE_CONNECTED: + begin + client.State := Connected; + Clients.Add(client); + end; + else + { Error occured } + FreeAndNil(client); + end; + end; + end; +end; + + +procedure TX2LogNamedPipeWorkerThread.RemoveClient(AClientIndex: Integer); +begin + Clients.Delete(AClientIndex); +end; + +end. diff --git a/X2Log.groupproj b/X2Log.groupproj new file mode 100644 index 0000000..3c6d543 --- /dev/null +++ b/X2Log.groupproj @@ -0,0 +1,48 @@ + + + {66C17964-1E71-4A50-A5F4-D04EB6A833D3} + + + + + + + + + + + Default.Personality.12 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/X2Log.pas b/X2Log.pas new file mode 100644 index 0000000..cd5da64 --- /dev/null +++ b/X2Log.pas @@ -0,0 +1,134 @@ +unit X2Log; + +interface +uses + System.Classes, + System.Generics.Collections, + System.SysUtils, + + X2Log.Intf; + + +type + TX2Log = class(TInterfacedObject, IX2Log, IX2LogMethods) + private + FExceptionStrategy: IX2LogExceptionStrategy; + FObservers: TList; + private + property ExceptionStrategy: IX2LogExceptionStrategy read FExceptionStrategy; + property Observers: TList 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 = ''); + procedure Error(const AMessage: string; const ADetails: string = ''); + procedure Exception(AException: Exception; const AMessage: string = ''; const ADetails: string = ''); + end; + + +implementation +uses + X2Log.Exception.Default; + + +{ TX2Log } +constructor TX2Log.Create; +begin + inherited Create; + + FObservers := TList.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 + FExceptionStrategy := AStrategy + else + FExceptionStrategy := TX2LogDefaultExceptionStrategy.Create; +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); +end; + + +procedure TX2Log.Info(const AMessage, ADetails: string); +begin + Log(TX2LogLevel.Info, AMessage, ADetails); +end; + + +procedure TX2Log.Warning(const AMessage, ADetails: string); +begin + Log(TX2LogLevel.Warning, AMessage, ADetails); +end; + + +procedure TX2Log.Error(const AMessage, ADetails: string); +begin + Log(TX2LogLevel.Error, AMessage, ADetails); +end; + + +procedure TX2Log.Exception(AException: Exception; const AMessage, ADetails: string); +var + msg: string; + details: string; + +begin + msg := AMessage; + details := ADetails; + + ExceptionStrategy.Execute(AException, msg, details); + Log(TX2LogLevel.Error, msg, details); +end; + +end.