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