summaryrefslogtreecommitdiff
path: root/src/corelib
diff options
context:
space:
mode:
Diffstat (limited to 'src/corelib')
-rw-r--r--src/corelib/fpg_dbugintf.pas337
-rw-r--r--src/corelib/fpg_dbugmsg.pas95
-rw-r--r--src/corelib/gdi/fpgui_toolkit.lpk10
-rw-r--r--src/corelib/gdi/fpgui_toolkit.pas2
-rw-r--r--src/corelib/x11/fpgui_toolkit.lpk10
-rw-r--r--src/corelib/x11/fpgui_toolkit.pas26
6 files changed, 465 insertions, 15 deletions
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 @@
<Description Value="fpGUI Toolkit"/>
<License Value="LGPL 2 with static linking exception."/>
<Version Major="1"/>
- <Files Count="98">
+ <Files Count="100">
<Item1>
<Filename Value="..\stdimages.inc"/>
<Type Value="Include"/>
@@ -424,6 +424,14 @@
<Filename Value="..\render\software\Agg2D.pas"/>
<UnitName Value="Agg2D"/>
</Item98>
+ <Item99>
+ <Filename Value="..\fpg_dbugintf.pas"/>
+ <UnitName Value="fpg_dbugintf"/>
+ </Item99>
+ <Item100>
+ <Filename Value="..\fpg_dbugmsg.pas"/>
+ <UnitName Value="fpg_dbugmsg"/>
+ </Item100>
</Files>
<LazDoc Paths="../../../docs/xml/corelib;../../../docs/xml/corelib/x11;../../../docs/xml/corelib/gdi;../../../docs/xml/gui"/>
<RequiredPkgs Count="1">
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 @@
<Description Value="fpGUI Toolkit"/>
<License Value="LGPL 2 with static linking exception."/>
<Version Major="1"/>
- <Files Count="99">
+ <Files Count="101">
<Item1>
<Filename Value="../stdimages.inc"/>
<Type Value="Include"/>
@@ -426,6 +426,14 @@
<Filename Value="../render/software/Agg2D.pas"/>
<UnitName Value="Agg2D"/>
</Item99>
+ <Item100>
+ <Filename Value="../fpg_dbugintf.pas"/>
+ <UnitName Value="fpg_dbugintf"/>
+ </Item100>
+ <Item101>
+ <Filename Value="../fpg_dbugmsg.pas"/>
+ <UnitName Value="fpg_dbugmsg"/>
+ </Item101>
</Files>
<LazDoc Paths="../../../docs/xml/corelib;../../../docs/xml/corelib/x11;../../../docs/xml/corelib/gdi;../../../docs/xml/gui"/>
<RequiredPkgs Count="1">
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
generated by cgit v1.2.3-70-g09d2 (git 2.47.1) at 2024-12-26 19:42:42 +0000