From 15e40c9ea4544a1a74f571f495e00d4bd122c76c Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Sat, 27 Apr 2013 18:41:17 +0100 Subject: new debug interface unit for use with out Debug Server application. Added debug interface units to 'corelib' and to the fpgui_toolkit packages --- src/corelib/fpg_dbugintf.pas | 337 ++++++++++++++++++++++++++++++++++++++ src/corelib/fpg_dbugmsg.pas | 95 +++++++++++ src/corelib/gdi/fpgui_toolkit.lpk | 10 +- src/corelib/gdi/fpgui_toolkit.pas | 2 +- src/corelib/x11/fpgui_toolkit.lpk | 10 +- src/corelib/x11/fpgui_toolkit.pas | 26 +-- 6 files changed, 465 insertions(+), 15 deletions(-) create mode 100644 src/corelib/fpg_dbugintf.pas create mode 100644 src/corelib/fpg_dbugmsg.pas (limited to 'src') diff --git a/src/corelib/fpg_dbugintf.pas b/src/corelib/fpg_dbugintf.pas new file mode 100644 index 00000000..8e9d9874 --- /dev/null +++ b/src/corelib/fpg_dbugintf.pas @@ -0,0 +1,337 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2005 by Michael Van Canneyt, member of + the Free Pascal development team + Copyright (C) 2013 by Graeme Geldenhuys + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Originally from the Free Pascal FCL. Since then the code has + diverged and was customised for fpGUI usage. + + This is the Client Interface for the debug server, which is + based on SimpleIPC. +} +unit fpg_dbugintf; + +{$mode objfpc}{$h+} + +interface + +uses + Classes, + fpg_base; + +Type + TDebugLevel = (dlStop, dlInformation, dlWarning, dlError, dlIdentify, dlLive); + +procedure SendBoolean(const Identifier: string; const Value: Boolean); +procedure SendDateTime(const Identifier: string; const Value: TDateTime); +procedure SendInteger(const Identifier: string; const Value: Integer; HexNotation: Boolean = False); +procedure SendPoint(const Identifier: string; const Value: TPoint; const ADbgLevel: TDebugLevel = dlLive); +procedure SendPointer(const Identifier: string; const Value: Pointer); +procedure SendRect(const Identifier: string; const Value: TRect; const ADbgLevel: TDebugLevel = dlInformation); +procedure SendRect(const Identifier: string; const Value: TfpgRect; const ADbgLevel: TDebugLevel = dlInformation); +procedure SendDebugEx(const Msg: string; MType: TDebugLevel); +procedure SendDebug(const Msg: string); +procedure SendMethodEnter(const MethodName: string); +procedure SendMethodExit(const MethodName: string); +procedure SendSeparator; +procedure SendDebugFmt(const Msg: string; const Args: array of const); +procedure SendDebugFmtEx(const Msg: string; const Args: array of const; MType: TDebugLevel; const ATitle: string = ''); + +procedure SetDebuggingEnabled(const AValue : boolean); +function GetDebuggingEnabled : Boolean; + +{ low-level routines } + +Function StartDebugServer : integer; +Function InitDebugClient : Boolean; +Function DebugMessageName(msgType: TDebugLevel) : String; + +Const + SendError : String = ''; + +ResourceString + SProcessID = 'Process %s'; + SEntering = '> Entering '; + SExiting = '< Exiting '; + SSeparator = '>-=-=-=-=-=-=-=-=-=-=-=-=-=-=-<'; + SServerStartFailed = 'Failed to start debugserver. (%s)'; + +implementation + +Uses + SysUtils, + process, + simpleipc, + fpg_dbugmsg; + +const + IndentChars = 2; + +var + DebugClient : TSimpleIPCClient = nil; + MsgBuffer : TMemoryStream = Nil; + ServerID : Integer; + DebugDisabled : Boolean = False; + Indent : Integer = 0; + +function RectToStr(const ARect: TRect): String; +begin + with ARect do + Result := Format('(Left: %d; Top: %d; Right: %d; Bottom: %d)', [Left, Top, Right, Bottom]); +end; + +function fpgRectToStr(const ARect: TfpgRect): String; +begin + with ARect do + Result := Format('(Left: %d; Top: %d; Width: %d; Height: %d)', [Left, Top, Width, Height]); +end; + +function PointToStr(const APoint: TPoint): String; +begin + with APoint do + Result := Format('(X: %d; Y: %d)', [X, Y]); +end; + +procedure WriteMessage(Const Msg : TDebugMessage); +begin + MsgBuffer.Seek(0, soFromBeginning); + WriteDebugMessageToStream(MsgBuffer, Msg); + DebugClient.SendMessage(mtUnknown, MsgBuffer); +end; + +procedure SendDebugMessage(Var Msg : TDebugMessage); +begin + if DebugDisabled then exit; + try + If (DebugClient=Nil) then + if InitDebugClient = false then exit; + if (Indent > 0) then + Msg.Msg := StringOfChar(' ', Indent) + Msg.Msg; + WriteMessage(Msg); + except + On E: Exception do + SendError := E.Message; + end; +end; + +procedure SendBoolean(const Identifier: string; const Value: Boolean); +const + Booleans : Array[Boolean] of string = ('False','True'); +begin + SendDebugFmt('%s = %s',[Identifier,Booleans[value]]); +end; + +procedure SendDateTime(const Identifier: string; const Value: TDateTime); +begin + SendDebugFmt('%s = %s',[Identifier,DateTimeToStr(Value)]); +end; + +procedure SendInteger(const Identifier: string; const Value: Integer; HexNotation: Boolean = False); +const + Msgs : Array[Boolean] of string = ('%s = %d','%s = %x'); +begin + SendDebugFmt(Msgs[HexNotation],[Identifier,Value]); +end; + +procedure SendPoint(const Identifier: string; const Value: TPoint; const ADbgLevel: TDebugLevel); +begin + SendDebugFmtEx('%s = %s',[Identifier, PointToStr(Value)], ADbgLevel); +end; + +procedure SendPointer(const Identifier: string; const Value: Pointer); +begin + SendDebugFmt('%s = %p',[Identifier,Value]); +end; + +procedure SendRect(const Identifier: string; const Value: TRect; const ADbgLevel: TDebugLevel); +begin + SendDebugFmtEx('%s',[RectToStr(Value)], ADbgLevel, Identifier); +end; + +procedure SendRect(const Identifier: string; const Value: TfpgRect; const ADbgLevel: TDebugLevel); +begin + SendDebugFmtEx('%s',[fpgRectToStr(Value)], ADbgLevel, Identifier); +end; + +procedure SendDebugEx(const Msg: string; MType: TDebugLevel); +var + Mesg : TDebugMessage; +begin + Mesg.MsgTimeStamp:=Now; + Mesg.MsgType:=Ord(MTYpe); + Mesg.Msg:=Msg; + SendDebugMessage(Mesg); +end; + +procedure SendDebug(const Msg: string); +var + Mesg : TDebugMessage; +begin + Mesg.MsgTimeStamp:=Now; + Mesg.MsgType:=Ord(dlInformation); + Mesg.Msg:=Msg; + SendDebugMessage(Mesg); +end; + +procedure SendMethodEnter(const MethodName: string); +begin + SendDebug(SEntering+MethodName); + inc(Indent,IndentChars); +end; + +procedure SendMethodExit(const MethodName: string); +begin + Dec(Indent,IndentChars); + If (Indent<0) then + Indent:=0; + SendDebug(SExiting+MethodName); +end; + +procedure SendSeparator; +begin + SendDebug(SSeparator); +end; + +procedure SendDebugFmt(const Msg: string; const Args: array of const); +var + Mesg : TDebugMessage; +begin + Mesg.MsgTimeStamp:=Now; + Mesg.MsgType:= Ord(dlInformation); + Mesg.Msg:=Format(Msg,Args); + SendDebugMessage(Mesg); +end; + +procedure SendDebugFmtEx(const Msg: string; const Args: array of const; MType: TDebugLevel; const ATitle: string); +var + Mesg: TDebugMessage; +begin + Mesg.MsgTimeStamp := Now; + Mesg.MsgType := Ord(mType); + if MType = dlLive then + Mesg.MsgTitle := ATitle + else + Mesg.MsgTitle := ' '; + Mesg.Msg := Format(Msg,Args); + SendDebugMessage(Mesg); +end; + +procedure SetDebuggingEnabled(const AValue: boolean); +begin + DebugDisabled := not AValue; +end; + +function GetDebuggingEnabled: Boolean; +begin + Result := not DebugDisabled; +end; + +function StartDebugServer : Integer; +begin + With TProcess.Create(Nil) do + begin + Try + CommandLine:='dbugsrv'; + Execute; + Result:=ProcessID; + Except On E: Exception do + begin + SendError := Format(SServerStartFailed,[E.Message]); + Result := 0; + end; + end; + Free; + end; +end; + +procedure FreeDebugClient; +var + msg : TDebugMessage; +begin + try + If (DebugClient<>Nil) and + (DebugClient.ServerRunning) then + begin + Msg.MsgType := Ord(dlStop); + Msg.MsgTimeStamp := Now; + Msg.Msg := Format(SProcessID,[ApplicationName]); + WriteMessage(Msg); + end; + if assigned(MsgBuffer) then + FreeAndNil(MsgBuffer); + if assigned(DebugClient) then + FreeAndNil(DebugClient); + except + end; +end; + +function InitDebugClient : Boolean; +var + msg : TDebugMessage; + I : Integer; +begin + Result := False; + DebugClient:=TSimpleIPCClient.Create(Nil); + DebugClient.ServerID:=DebugServerID; + If not DebugClient.ServerRunning then + begin + ServerID:=StartDebugServer; + if ServerID = 0 then + begin + DebugDisabled := True; + FreeAndNil(DebugClient); + Exit; + end + else + DebugDisabled := False; + I:=0; + While (I<10) and not DebugClient.ServerRunning do + begin + Inc(I); + Sleep(100); + end; + end; + try + DebugClient.Connect; + except + FreeAndNil(DebugClient); + DebugDisabled:=True; + Raise; + end; + MsgBuffer := TMemoryStream.Create; + Msg.MsgType := Ord(dlIdentify); + Msg.MsgTimeStamp := Now; + Msg.Msg := Format(SProcessID,[ApplicationName]); + WriteMessage(Msg); + Result := True; +end; + +Function DebugMessageName(msgType : TDebugLevel) : String; +begin + Case MsgType of + dlStop : Result := 'Stop'; + dlInformation : Result := 'Information'; + dlWarning : Result := 'Warning'; + dlError : Result := 'Error'; + dlIdentify : Result := 'Identify'; + dlLive : Result := 'LiveView'; + else + Result := 'Unknown'; + end; +end; + + +finalization + FreeDebugClient; + +end. diff --git a/src/corelib/fpg_dbugmsg.pas b/src/corelib/fpg_dbugmsg.pas new file mode 100644 index 00000000..502b697e --- /dev/null +++ b/src/corelib/fpg_dbugmsg.pas @@ -0,0 +1,95 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2005 by Michael Van Canneyt, member of + the Free Pascal development team + Copyright (C) 2013 by Graeme Geldenhuys + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Originally from the Free Pascal FCL. Since then the code has + diverged and was customised for fpGUI usage. +} +unit fpg_dbugmsg; + +{$mode objfpc}{$h+} + +interface + +uses Classes; + +Const + DebugServerID : String = 'fpgDebugServer'; + +Type + TDebugMessage = record + MsgType : Integer; + MsgTimeStamp : TDateTime; + MsgTitle : string; + Msg : string; + end; + +Procedure ReadDebugMessageFromStream(AStream : TStream; Var Msg : TDebugMessage); +Procedure WriteDebugMessageToStream(AStream : TStream; Const Msg : TDebugMessage); + + +implementation + + +procedure ReadDebugMessageFromStream(AStream : TStream; Var Msg : TDebugMessage); +var + MsgSize: Integer; +begin + MsgSize := 0; + with AStream do + begin + ReadBuffer(Msg.MsgType, SizeOf(Integer)); + ReadBuffer(Msg.MsgTimeStamp, SizeOf(TDateTime)); + + ReadBuffer(MsgSize, SizeOf(Integer)); + SetLength(Msg.MsgTitle, MsgSize); + if (MsgSize<>0) then + ReadBuffer(Msg.MsgTitle[1], MsgSize); + + ReadBuffer(MsgSize, SizeOf(Integer)); + SetLength(Msg.Msg, MsgSize); + if (MsgSize<>0) then + ReadBuffer(Msg.Msg[1], MsgSize); + end; +end; + +procedure WriteDebugMessageToStream(AStream : TStream; Const Msg : TDebugMessage); +var + MsgSize : Integer; + lTitle: string; +begin + with AStream do + begin + WriteBuffer(Msg.MsgType, SizeOf(Integer)); + WriteBuffer(Msg.MsgTimeStamp, SizeOf(TDateTime)); + + MsgSize := Length(Msg.MsgTitle); + if MsgSize = 0 then // fake a title + begin + MsgSize := 1; + lTitle := ' '; + end + else + lTitle := Msg.MsgTitle; + WriteBuffer(MsgSize, SizeOf(Integer)); + WriteBuffer(lTitle[1], MsgSize); + + MsgSize := Length(Msg.Msg); + WriteBuffer(MsgSize, SizeOf(Integer)); + WriteBuffer(Msg.Msg[1], MsgSize); + end; +end; + + +end. diff --git a/src/corelib/gdi/fpgui_toolkit.lpk b/src/corelib/gdi/fpgui_toolkit.lpk index bf019e5f..0434ab23 100644 --- a/src/corelib/gdi/fpgui_toolkit.lpk +++ b/src/corelib/gdi/fpgui_toolkit.lpk @@ -31,7 +31,7 @@ - + @@ -424,6 +424,14 @@ + + + + + + + + diff --git a/src/corelib/gdi/fpgui_toolkit.pas b/src/corelib/gdi/fpgui_toolkit.pas index 05501714..922109c3 100644 --- a/src/corelib/gdi/fpgui_toolkit.pas +++ b/src/corelib/gdi/fpgui_toolkit.pas @@ -21,7 +21,7 @@ uses fpg_interface, fpg_editbtn, fpg_imgfmt_jpg, fpg_imgutils, fpg_stylemanager, fpg_style_win2k, fpg_style_motif, fpg_style_clearlooks, fpg_style_bluecurve, fpg_style_bitmap, fpg_readonly, fpg_imgfmt_png, U_Command, U_Pdf, U_Report, - U_ReportImages, U_Visu, fpg_trayicon, Agg2D; + U_ReportImages, U_Visu, fpg_trayicon, Agg2D, fpg_dbugintf, fpg_dbugmsg; implementation diff --git a/src/corelib/x11/fpgui_toolkit.lpk b/src/corelib/x11/fpgui_toolkit.lpk index c769331e..4616f7c4 100644 --- a/src/corelib/x11/fpgui_toolkit.lpk +++ b/src/corelib/x11/fpgui_toolkit.lpk @@ -29,7 +29,7 @@ - + @@ -426,6 +426,14 @@ + + + + + + + + diff --git a/src/corelib/x11/fpgui_toolkit.pas b/src/corelib/x11/fpgui_toolkit.pas index 10dc7f27..65239b89 100644 --- a/src/corelib/x11/fpgui_toolkit.pas +++ b/src/corelib/x11/fpgui_toolkit.pas @@ -8,19 +8,21 @@ interface uses fpg_base, fpg_main, fpg_cmdlineparams, fpg_command_intf, fpg_constants, - fpg_extinterpolation, fpg_imagelist, fpg_imgfmt_bmp, fpg_pofiles, fpg_popupwindow, - fpg_stdimages, fpg_stringhashlist, fpg_translations, fpg_stringutils, fpg_utils, - fpg_widget, fpg_wuline, fpg_impl, fpg_x11, fpg_netlayer_x11, fpg_keyconv_x11, - fpg_xft_x11, fpg_animation, fpg_basegrid, fpg_button, fpg_checkbox, fpg_combobox, - fpg_customgrid, fpg_dialogs, fpg_editcombo, fpg_edit, fpg_form, fpg_gauge, fpg_grid, - fpg_hyperlink, fpg_iniutils, fpg_label, fpg_listbox, fpg_listview, fpg_memo, fpg_menu, + fpg_extinterpolation, fpg_imagelist, fpg_imgfmt_bmp, fpg_pofiles, + fpg_popupwindow, fpg_stdimages, fpg_stringhashlist, fpg_translations, + fpg_stringutils, fpg_utils, fpg_widget, fpg_wuline, fpg_impl, fpg_x11, + fpg_netlayer_x11, fpg_keyconv_x11, fpg_xft_x11, fpg_animation, fpg_basegrid, + fpg_button, fpg_checkbox, fpg_combobox, fpg_customgrid, fpg_dialogs, + fpg_editcombo, fpg_edit, fpg_form, fpg_gauge, fpg_grid, fpg_hyperlink, + fpg_iniutils, fpg_label, fpg_listbox, fpg_listview, fpg_memo, fpg_menu, fpg_mru, fpg_panel, fpg_popupcalendar, fpg_progressbar, fpg_radiobutton, - fpg_scrollbar, fpg_style, fpg_tab, fpg_trackbar, fpg_tree, fpgui_db, fpg_splitter, - fpg_hint, fpg_spinedit, fpg_extgraphics, fpg_ColorMapping, fpg_ColorWheel, - fpg_interface, fpg_editbtn, fpg_imgfmt_jpg, fpg_imgutils, fpg_stylemanager, - fpg_style_win2k, fpg_style_motif, fpg_style_clearlooks, fpg_style_bluecurve, - fpg_style_bitmap, fpg_readonly, fpg_imgfmt_png, U_Command, U_Pdf, U_Report, - U_ReportImages, U_Visu, fpg_trayicon, Agg2D; + fpg_scrollbar, fpg_style, fpg_tab, fpg_trackbar, fpg_tree, fpgui_db, + fpg_splitter, fpg_hint, fpg_spinedit, fpg_extgraphics, fpg_ColorMapping, + fpg_ColorWheel, fpg_interface, fpg_editbtn, fpg_imgfmt_jpg, fpg_imgutils, + fpg_stylemanager, fpg_style_win2k, fpg_style_motif, fpg_style_clearlooks, + fpg_style_bluecurve, fpg_style_bitmap, fpg_readonly, fpg_imgfmt_png, + U_Command, U_Pdf, U_Report, U_ReportImages, U_Visu, fpg_trayicon, Agg2D, + fpg_dbugintf, fpg_dbugmsg; implementation -- cgit v1.2.3-70-g09d2