/packages/fcl-process/src/dbugintf.pp

https://github.com/slibre/freepascal · Puppet · 294 lines · 235 code · 59 blank · 0 comment · 7 complexity · e7021a2f5a713e0c6f218c2ed2284465 MD5 · raw file

  1. {
  2. This file is part of the Free Component library.
  3. Copyright (c) 2005 by Michael Van Canneyt, member of
  4. the Free Pascal development team
  5. Debugserver client interface, based on SimpleIPC
  6. See the file COPYING.FPC, included in this distribution,
  7. for details about the copyright.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  11. **********************************************************************}
  12. {$mode objfpc}
  13. {$h+}
  14. unit dbugintf;
  15. interface
  16. Type
  17. TDebugLevel = (dlInformation,dlWarning,dlError);
  18. procedure SendBoolean(const Identifier: string; const Value: Boolean);
  19. procedure SendDateTime(const Identifier: string; const Value: TDateTime);
  20. procedure SendInteger(const Identifier: string; const Value: Integer; HexNotation: Boolean = False);
  21. procedure SendPointer(const Identifier: string; const Value: Pointer);
  22. procedure SendDebugEx(const Msg: string; MType: TDebugLevel);
  23. procedure SendDebug(const Msg: string);
  24. procedure SendMethodEnter(const MethodName: string);
  25. procedure SendMethodExit(const MethodName: string);
  26. procedure SendSeparator;
  27. procedure SendDebugFmt(const Msg: string; const Args: array of const);
  28. procedure SendDebugFmtEx(const Msg: string; const Args: array of const; MType: TDebugLevel);
  29. procedure SetDebuggingEnabled(const AValue : boolean);
  30. function GetDebuggingEnabled : Boolean;
  31. { low-level routines }
  32. Function StartDebugServer : integer;
  33. Function InitDebugClient : Boolean;
  34. Const
  35. SendError : String = '';
  36. ResourceString
  37. SProcessID = 'Process %s';
  38. SEntering = '> Entering ';
  39. SExiting = '< Exiting ';
  40. SSeparator = '>-=-=-=-=-=-=-=-=-=-=-=-=-=-=-<';
  41. SServerStartFailed = 'Failed to start debugserver. (%s)';
  42. implementation
  43. Uses
  44. SysUtils, classes,dbugmsg, process, simpleipc;
  45. Const
  46. DmtInformation = lctInformation;
  47. DmtWarning = lctWarning;
  48. DmtError = lctError;
  49. ErrorLevel : Array[TDebugLevel] of integer
  50. = (dmtInformation,dmtWarning,dmtError);
  51. IndentChars = 2;
  52. var
  53. DebugClient : TSimpleIPCClient = nil;
  54. MsgBuffer : TMemoryStream = Nil;
  55. ServerID : Integer;
  56. DebugDisabled : Boolean = False;
  57. Indent : Integer = 0;
  58. Procedure WriteMessage(Const Msg : TDebugMessage);
  59. begin
  60. MsgBuffer.Seek(0,soFrombeginning);
  61. WriteDebugMessageToStream(MsgBuffer,Msg);
  62. DebugClient.SendMessage(mtUnknown,MsgBuffer);
  63. end;
  64. procedure SendDebugMessage(Var Msg : TDebugMessage);
  65. begin
  66. if DebugDisabled then exit;
  67. try
  68. If (DebugClient=Nil) then
  69. if InitDebugClient = false then exit;
  70. if (Indent>0) then
  71. Msg.Msg:=StringOfChar(' ',Indent)+Msg.Msg;
  72. WriteMessage(Msg);
  73. except
  74. On E : Exception do
  75. SendError:=E.Message;
  76. end;
  77. end;
  78. procedure SendBoolean(const Identifier: string; const Value: Boolean);
  79. Const
  80. Booleans : Array[Boolean] of string = ('False','True');
  81. begin
  82. SendDebugFmt('%s = %s',[Identifier,Booleans[value]]);
  83. end;
  84. procedure SendDateTime(const Identifier: string; const Value: TDateTime);
  85. begin
  86. SendDebugFmt('%s = %s',[Identifier,DateTimeToStr(Value)]);
  87. end;
  88. procedure SendInteger(const Identifier: string; const Value: Integer; HexNotation: Boolean = False);
  89. Const
  90. Msgs : Array[Boolean] of string = ('%s = %d','%s = %x');
  91. begin
  92. SendDebugFmt(Msgs[HexNotation],[Identifier,Value]);
  93. end;
  94. procedure SendPointer(const Identifier: string; const Value: Pointer);
  95. begin
  96. SendDebugFmt('%s = %p',[Identifier,Value]);
  97. end;
  98. procedure SendDebugEx(const Msg: string; MType: TDebugLevel);
  99. Var
  100. Mesg : TDebugMessage;
  101. begin
  102. Mesg.MsgTimeStamp:=Now;
  103. Mesg.MsgType:=ErrorLevel[MTYpe];
  104. Mesg.Msg:=Msg;
  105. SendDebugMessage(Mesg);
  106. end;
  107. procedure SendDebug(const Msg: string);
  108. Var
  109. Mesg : TDebugMessage;
  110. begin
  111. Mesg.MsgTimeStamp:=Now;
  112. Mesg.MsgType:=dmtInformation;
  113. Mesg.Msg:=Msg;
  114. SendDebugMessage(Mesg);
  115. end;
  116. procedure SendMethodEnter(const MethodName: string);
  117. begin
  118. SendDebug(SEntering+MethodName);
  119. inc(Indent,IndentChars);
  120. end;
  121. procedure SendMethodExit(const MethodName: string);
  122. begin
  123. Dec(Indent,IndentChars);
  124. If (Indent<0) then
  125. Indent:=0;
  126. SendDebug(SExiting+MethodName);
  127. end;
  128. procedure SendSeparator;
  129. begin
  130. SendDebug(SSeparator);
  131. end;
  132. procedure SendDebugFmt(const Msg: string; const Args: array of const);
  133. Var
  134. Mesg : TDebugMessage;
  135. begin
  136. Mesg.MsgTimeStamp:=Now;
  137. Mesg.MsgType:=dmtInformation;
  138. Mesg.Msg:=Format(Msg,Args);
  139. SendDebugMessage(Mesg);
  140. end;
  141. procedure SendDebugFmtEx(const Msg: string; const Args: array of const; MType: TDebugLevel);
  142. Var
  143. Mesg : TDebugMessage;
  144. begin
  145. Mesg.MsgTimeStamp:=Now;
  146. Mesg.MsgType:=ErrorLevel[mType];
  147. Mesg.Msg:=Format(Msg,Args);
  148. SendDebugMessage(Mesg);
  149. end;
  150. procedure SetDebuggingEnabled(const AValue: boolean);
  151. begin
  152. DebugDisabled := not AValue;
  153. end;
  154. function GetDebuggingEnabled: Boolean;
  155. begin
  156. Result := not DebugDisabled;
  157. end;
  158. function StartDebugServer : Integer;
  159. begin
  160. With TProcess.Create(Nil) do
  161. begin
  162. Try
  163. CommandLine:='dbugsrv';
  164. Execute;
  165. Result:=ProcessID;
  166. Except On E: Exception do
  167. begin
  168. SendError := Format(SServerStartFailed,[E.Message]);
  169. Result := 0;
  170. end;
  171. end;
  172. Free;
  173. end;
  174. end;
  175. procedure FreeDebugClient;
  176. Var
  177. msg : TDebugMessage;
  178. begin
  179. try
  180. If (DebugClient<>Nil) and
  181. (DebugClient.ServerRunning) then
  182. begin
  183. Msg.MsgType:=lctStop;
  184. Msg.MsgTimeStamp:=Now;
  185. Msg.Msg:=Format(SProcessID,[ApplicationName]);
  186. WriteMessage(Msg);
  187. end;
  188. if assigned(MsgBuffer) then FreeAndNil(MsgBuffer);
  189. if assigned(DebugClient) then FreeAndNil(DebugClient);
  190. except
  191. end;
  192. end;
  193. Function InitDebugClient : Boolean;
  194. Var
  195. msg : TDebugMessage;
  196. I : Integer;
  197. begin
  198. Result := False;
  199. DebugClient:=TSimpleIPCClient.Create(Nil);
  200. DebugClient.ServerID:=DebugServerID;
  201. If not DebugClient.ServerRunning then
  202. begin
  203. ServerID:=StartDebugServer;
  204. if ServerID = 0 then
  205. begin
  206. DebugDisabled := True;
  207. FreeAndNil(DebugClient);
  208. Exit;
  209. end
  210. else
  211. DebugDisabled := False;
  212. I:=0;
  213. While (I<10) and not DebugClient.ServerRunning do
  214. begin
  215. Inc(I);
  216. Sleep(100);
  217. end;
  218. end;
  219. try
  220. DebugClient.Connect;
  221. except
  222. FreeAndNil(DebugClient);
  223. DebugDisabled:=True;
  224. Raise;
  225. end;
  226. MsgBuffer:=TMemoryStream.Create;
  227. Msg.MsgType:=lctIdentify;
  228. Msg.MsgTimeStamp:=Now;
  229. Msg.Msg:=Format(SProcessID,[ApplicationName]);
  230. WriteMessage(Msg);
  231. Result := True;
  232. end;
  233. Finalization
  234. FreeDebugClient;
  235. end.