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

  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.