Merge branch 'debugserver-liveview' into develop

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