paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-06-07 09:18:18 +02:00
Code Issues Packages Projects Releases Wiki Activity

FPDServer: Stand-alone debugger that can be controlled from the console or remote through tcp/ip

Browse Source 
git-svn-id: trunk@48991 -
This commit is contained in:
joost 2015-05-12 06:25:21 +00:00
parent b4b8dab3b4
commit 001be758a5
9 changed files with 1660 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
.gitattributes vendored
View File

@ -1343,6 +1343,14 @@ components/fpdebug/app/fpd/fpdpeimage.pas svneol=native#text/pascal
components/fpdebug/app/fpd/fpdtype.pas svneol=native#text/pascal components/fpdebug/app/fpd/fpdtype.pas svneol=native#text/pascal
components/fpdebug/app/fpdd/fpdumpdwarf.lpi svneol=native#text/plain components/fpdebug/app/fpdd/fpdumpdwarf.lpi svneol=native#text/plain
components/fpdebug/app/fpdd/fpdumpdwarf.lpr svneol=native#text/pascal components/fpdebug/app/fpdd/fpdumpdwarf.lpr svneol=native#text/pascal
components/fpdebug/app/fpdserver/Info.plist svneol=native#text/plain
components/fpdebug/app/fpdserver/debuginoutputprocessor.pas svneol=native#text/plain
components/fpdebug/app/fpdserver/debugtcpserver.pas svneol=native#text/plain
components/fpdebug/app/fpdserver/debugthread.pas svneol=native#text/plain
components/fpdebug/app/fpdserver/debugthreadcommand.pas svneol=native#text/plain
components/fpdebug/app/fpdserver/fpdserver.lpi svneol=native#text/plain
components/fpdebug/app/fpdserver/fpdserver.lpr svneol=native#text/plain
components/fpdebug/app/fpdserver/readme.txt svneol=native#text/plain
components/fpdebug/fpdbgclasses.pp svneol=native#text/pascal components/fpdebug/fpdbgclasses.pp svneol=native#text/pascal
components/fpdebug/fpdbgcontroller.pas svneol=native#text/plain components/fpdebug/fpdbgcontroller.pas svneol=native#text/plain
components/fpdebug/fpdbgdarwinclasses.pas svneol=native#text/plain components/fpdebug/fpdbgdarwinclasses.pas svneol=native#text/plain

20
components/fpdebug/app/fpdserver/Info.plist Normal file
View File

@ -0,0 +1,20 @@
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
<plist version="1.0">
<dict>
<key>CFBundleDevelopmentRegion</key>
<string>English</string>
<key>CFBundleIdentifier</key>
<string>org.freepascal.fpdserver</string>
<key>CFBundleInfoDictionaryVersion</key>
<string>6.0</string>
<key>CFBundleName</key>
<string>fpdserver</string>
<key>CFBundleVersion</key>
<string>1.0</string>
<key>SecTaskAccess</key>
<array>
<string>allowed</string>
</array>
</dict>
</plist>

197
components/fpdebug/app/fpdserver/debuginoutputprocessor.pas Normal file
View File

@ -0,0 +1,197 @@
unit DebugInOutputProcessor;
{$mode objfpc}{$H+}
interface
uses
Classes,
SysUtils,
fpjson,
FpDbgUtil,
DebugThreadCommand,
debugthread,
FpDbgClasses,
typinfo,
varutils,
variants,
jsonparser;
type
{ TCustomInOutputProcessor }
TCustomInOutputProcessor = class
private
FConnectionIdentifier: integer;
protected
FOnLog: TOnLog;
public
constructor create(AConnectionIdentifier: integer; AnOnLog: TOnLog); virtual;
function TextToCommand(const ACommandText: string): TFpDebugThreadCommand; virtual; abstract;
function EventToText(AnEvent: TFpDebugEvent): string; virtual; abstract;
end;
{ TJSonInOutputProcessor }
TJSonInOutputProcessor = class(TCustomInOutputProcessor)
public
function TextToCommand(const ACommandText: string): TFpDebugThreadCommand; override;
function EventToText(AnEvent: TFpDebugEvent): string; override;
end;
implementation
var
GJSonInOutputProcessor: TJSonInOutputProcessor = nil;
{ TCustomInOutputProcessor }
constructor TCustomInOutputProcessor.create(AConnectionIdentifier: integer; AnOnLog: TOnLog);
begin
FConnectionIdentifier:=AConnectionIdentifier;
FOnLog:=AnOnLog;
end;
{ TJSonInOutputProcessor }
function TJSonInOutputProcessor.TextToCommand(const ACommandText: string): TFpDebugThreadCommand;
var
AJSonCommand: TJSONData;
AJSonProp: TJSONData;
AJSonUID: TJSONData;
AnUID: variant;
ACommandClass: TFpDebugThreadCommandClass;
s: string;
i: integer;
APropCount: integer;
APropList: PPropList;
APropName: string;
begin
result := nil;
try
AJSonCommand := GetJSON(ACommandText);
except
on E: Exception do
begin
TFpDebugThread.Instance.SendNotification(FConnectionIdentifier, ntInvalidCommand, NULL, 'Command "%s" is not a valid JSON string: %s', ACommandText, [ACommandText, e.Message]);
Exit;
end;
end;
if not assigned(AJSonCommand) then
begin
TFpDebugThread.Instance.SendNotification(FConnectionIdentifier, ntInvalidCommand, NULL, 'Command "%s" is not a valid JSON string.', ACommandText, [ACommandText]);
exit;
end;
try
if AJSonCommand.JSONType<>jtObject then
begin
TFpDebugThread.Instance.SendNotification(FConnectionIdentifier, ntInvalidCommand, NULL, 'Command "%s" is not a JSON-object.', ACommandText, [ACommandText]);
exit;
end;
s := TJSONObject(AJSonCommand).Get('command', '');
if s = '' then
begin
TFpDebugThread.Instance.SendNotification(FConnectionIdentifier, ntInvalidCommand, NULL, 'Command "%s" does not contain a "command" entry.', ACommandText,[ACommandText]);
exit;
end;
ACommandClass := TFpDebugThreadCommandList.instance.GetCommandByName(s);
if not assigned(ACommandClass) then
begin
TFpDebugThread.Instance.SendNotification(FConnectionIdentifier, ntInvalidCommand, NULL, 'Command "%s" does not exist.', s, [S]);
exit;
end;
AJSonUID := TJSONObject(AJSonCommand).find('uid');
if assigned(AJSonUID) then
AnUID := AJSonUID.Value
else
AnUID := null;
result := ACommandClass.Create(FConnectionIdentifier, AnUID, FOnLog);
APropCount := GetPropList(result, APropList);
for i := 0 to APropCount-1 do
begin
APropName := APropList^[i]^.Name;
AJSonProp := TJSONObject(AJSonCommand).Find(LowerCase(APropName));
if assigned(AJSonProp) then
begin
case APropList^[i]^.PropType^.Kind of
tkAString, tkString, tkUString:
SetStrProp(result, APropList^[i], AJSonProp.AsString);
tkInteger:
SetOrdProp(result, APropList^[i], AJSonProp.AsInteger);
end;
end;
end;
finally
AJSonCommand.Free;
end;
end;
function TJSonInOutputProcessor.EventToText(AnEvent: TFpDebugEvent): string;
var
s: string;
JSonEvent: TJSONObject;
JSonLocationRec: TJSONObject;
begin
JSonEvent := TJSONObject.Create;
try
JSonEvent.Add('type',FpEventTypeNames[AnEvent.EventType]);
if AnEvent.BreakpointAddr<>0 then
JSonEvent.Add('breakpointLocation', FormatAddress(AnEvent.BreakpointAddr));
if AnEvent.SendByConnectionIdentifier>0 then
JSonEvent.Add('connIdentifier', AnEvent.SendByConnectionIdentifier);
if AnEvent.LocationRec.Address <> 0 then
begin
JSonLocationRec := TJSONObject.Create;
JSonLocationRec.Add('address', FormatAddress(AnEvent.LocationRec.Address));
JSonLocationRec.Add('funcName', AnEvent.LocationRec.FuncName);
JSonLocationRec.Add('srcFile', AnEvent.LocationRec.SrcFile);
JSonLocationRec.Add('srcFullName', AnEvent.LocationRec.SrcFullName);
JSonLocationRec.Add('srcLine', AnEvent.LocationRec.SrcLine);
JSonEvent.Add('locationRec',JSonLocationRec);
end;
if not varisnull(AnEvent.AnUID) then
begin
if VarIsOrdinal(AnEvent.AnUID) then
JSonEvent.Add('uid', integer(AnEvent.AnUID))
else
JSonEvent.Add('uid', VarToStr(AnEvent.AnUID));
end;
case AnEvent.EventType of
etEvent:
begin
JSonEvent.Add('eventName',AnEvent.EventName);
if AnEvent.InstructionPointerRegValue<>0 then
JSonEvent.Add('instrPointer', FormatAddress(AnEvent.InstructionPointerRegValue));
end;
etLog :
begin
JSonEvent.Add('message',AnEvent.Message);
case AnEvent.LogLevel of
dllDebug: JSonEvent.Add('logType','debug');
dllError: JSonEvent.Add('logType','error');
dllInfo: JSonEvent.Add('logType','info');
end;
end;
etNotification:
begin
JSonEvent.Add('notificationType',FpDebugNotificationTypeNames[AnEvent.NotificationType]);
JSonEvent.Add('message',AnEvent.Message);
if AnEvent.EventName<>'' then
JSonEvent.Add('command',AnEvent.EventName);
end;
end;
result := JSonEvent.AsJSON;
finally
JSonEvent.Free;
end;
end;
finalization
GJSonInOutputProcessor := nil;
end.

297
components/fpdebug/app/fpdserver/debugtcpserver.pas Normal file
View File

@ -0,0 +1,297 @@
unit DebugTCPServer;
{$mode objfpc}{$H+}
interface
uses
Classes,
SysUtils,
ssockets,
BaseUnix,
debugthread,
sockets,
syncobjs,
FpDbgClasses,
lazfglhash,
lazCollections,
fpjson,
fgl,
DebugInOutputProcessor,
DebugThreadCommand;
type
{ TFpDebugTcpServer }
TFpDebugTcpConnectionThread = class;
TThreadedQueueString = specialize TLazThreadedQueue<string>;
TConnectionList = specialize TFPGObjectList<TFpDebugTcpConnectionThread>;
TFpDebugTcpServer = class(TThread)
private
FTCPConnection: TInetServer;
FConnectionList: TConnectionList;
FDebugThread: TFpDebugThread;
procedure FTCPConnectionConnect(Sender: TObject; Data: TSocketStream);
procedure FTCPConnectionAcceptError(Sender: TObject; ASocket: Longint; E: Exception; var ErrorAction: TAcceptErrorAction);
procedure FTCPConnectionConnectQuery(Sender: TObject; ASocket: Longint; var Allow: Boolean);
protected
procedure Execute; override;
public
procedure StopListening;
constructor create(ADebugThread: TFpDebugThread);
procedure RemoveConnection(ADebugTcpConnectionThread: TFpDebugTcpConnectionThread);
destructor Destroy; override;
end;
{ TFpDebugTcpConnectionThread }
TFpDebugTcpConnectionThread = class(tthread, IFpDebugListener)
private
FData: TSocketStream;
FDebugThread: TFpDebugThread;
FResponseQueue: TThreadedQueueString;
FDebugTcpServer: TFpDebugTcpServer;
FConnectionIdentifier: integer;
FInOutputProcessor: TCustomInOutputProcessor;
protected
procedure Execute; override;
procedure SendCommand(ACommandStr: string);
public
procedure SendEvent(AnEvent: TFpDebugEvent);
function GetOrigin: string;
constructor create(ADebugThread: TFpDebugThread; ADebugTcpServer: TFpDebugTcpServer; Data: TSocketStream);
destructor Destroy; override;
end;
implementation
{ TFpDebugTcpConnectionThread }
function STrToStr(AStr: string): string;
var i : integer;
begin
result := '';
for i := 1 to length(AStr) do
if ord(AStr[i])<20 then
result := result +'#'+inttostr(ord(AStr[i]))
else
result := result + Astr[i];
end;
procedure TFpDebugTcpConnectionThread.Execute;
procedure WriteString(AStr: string);
var
i: integer;
begin
AStr := AStr + #10;
i := FData.Write(AStr[1], length(AStr));
if i < 0 then
begin
if FData.LastError=32 then
begin
// Lost connection
end
else
FDebugThread.SendNotification(FConnectionIdentifier, ntConnectionProblem, null, 'Error during write. Socket-error: %d', '', [FData.LastError]);
Terminate;
end
else if i < length(AStr) then
raise exception.create('Message has not been send to client entirely');
end;
const
InputBufferSize = 1024;
var
s: string;
i: integer;
InputBuffer: array[0..InputBufferSize-1] of char;
InputStr: string;
begin
WriteString('Welcome to FPDebug-server.');
if not Terminated then
WriteString('Your connection-idenfifier is '+IntToStr(FConnectionIdentifier)+'.');
if not Terminated then
WriteString('Send "help<enter>" for more information.');
while not terminated do
begin
i := FData.Read(InputBuffer[0], InputBufferSize);
if i > 0 then
begin
setlength(s,i);
move(InputBuffer[0],s[1],i);
s := StringReplace(s,#13#10,#10,[rfReplaceAll]);
InputStr:=InputStr+s;
i := pos(#10, InputStr);
while i > 0 do
begin
s := copy(InputStr, 1, i-1);
delete(InputStr,1,i);
SendCommand(S);
i := pos(#10, InputStr);
end;
end
else if i < 0 then
begin
if FData.LastError<>35 {EAGAIN} then
begin
writeln('Error during write. Socket-error: '+inttostr(FData.LastError));
Terminate;
end;
end
else if i = 0 then
begin
// Zero-count -> Connection closed
Terminate;
end;
if not terminated and (FResponseQueue.PopItem(s) = wrSignaled) then
begin
WriteString(s);
end;
end;
FDebugTcpServer.RemoveConnection(self);
end;
procedure TFpDebugTcpConnectionThread.SendCommand(ACommandStr: string);
var
ACommand: TFpDebugThreadCommand;
begin
ACommand := FInOutputProcessor.TextToCommand(ACommandStr);
if assigned(ACommand) then
FDebugThread.QueueCommand(ACommand);
end;
procedure TFpDebugTcpConnectionThread.SendEvent(AnEvent: TFpDebugEvent);
var
s: string;
begin
s := FInOutputProcessor.EventToText(AnEvent);
FResponseQueue.PushItem(s);
end;
function TFpDebugTcpConnectionThread.GetOrigin: string;
begin
result := format('%d.%d.%d.%d:%d', [FData.RemoteAddress.sin_addr.s_bytes[1], FData.RemoteAddress.sin_addr.s_bytes[2],FData.RemoteAddress.sin_addr.s_bytes[3], FData.RemoteAddress.sin_addr.s_bytes[4], FData.RemoteAddress.sin_port])
end;
constructor TFpDebugTcpConnectionThread.create(ADebugThread: TFpDebugThread;
ADebugTcpServer: TFpDebugTcpServer; Data: TSocketStream);
begin
FData := data;
// Set non-blocking
fpfcntl(FData.Handle,F_SETFL,O_NONBLOCK);
FDebugThread := ADebugThread;
FDebugTcpServer := ADebugTcpServer;
FResponseQueue:=TThreadedQueueString.create(100, INFINITE, 100);
FConnectionIdentifier := FDebugThread.AddListener(self);
FInOutputProcessor := TJSonInOutputProcessor.create(FConnectionIdentifier, @ADebugThread.SendLogMessage);
inherited create(false);
end;
destructor TFpDebugTcpConnectionThread.Destroy;
begin
FInOutputProcessor.Free;
FDebugThread.RemoveListener(self);
FResponseQueue.Free;
FData.Free;
inherited Destroy;
end;
{ TFpDebugTcpServer }
procedure TFpDebugTcpServer.FTCPConnectionAcceptError(Sender: TObject;
ASocket: Longint; E: Exception; var ErrorAction: TAcceptErrorAction);
begin
if E is ESocketError and (ESocketError(E).Code=seAcceptFailed) and (socketerror=53) {ECONNABORTED} then
begin
// The socket has stopped listening. The TCP-server is shutting down...
ErrorAction:=aeaStop;
end
else
writeln('ErrorAction a: '+e.ClassName + ' -- ',ErrorAction, '::',socketerror);
end;
procedure TFpDebugTcpServer.FTCPConnectionConnectQuery(Sender: TObject;
ASocket: Longint; var Allow: Boolean);
begin
Allow:=true;
end;
procedure TFpDebugTcpServer.FTCPConnectionConnect(Sender: TObject; Data: TSocketStream);
var
AConnectionThread: TFpDebugTcpConnectionThread;
begin
AConnectionThread:=TFpDebugTcpConnectionThread.create(FDebugThread, Self, data);
AConnectionThread.FreeOnTerminate:=true;
FConnectionList.Add(AConnectionThread);
end;
procedure TFpDebugTcpServer.Execute;
var
AConnection: TInetServer;
begin
try
FTCPConnection := TInetServer.Create(9001);
try
FTCPConnection.OnConnect:=@FTCPConnectionConnect;
FTCPConnection.OnConnectQuery:=@FTCPConnectionConnectQuery;
FTCPConnection.OnAcceptError:=@FTCPConnectionAcceptError;
FTCPConnection.Listen;
FTCPConnection.StartAccepting;
finally
AConnection:=FTCPConnection;
FTCPConnection := nil;
AConnection.Free;
end;
Except
on E: Exception do
begin
if (E is ESocketError) and (ESocketError(E).Code=seBindFailed) then
FDebugThread.SendNotification(-1, ntConnectionProblem, null, 'Failed to start listening for incoming TCP-connections: %s', '', [e.Message])
else
WriteLn('Exception: '+e.Message);
end;
end;
end;
procedure TFpDebugTcpServer.StopListening;
begin
Terminate;
if assigned(FTCPConnection) then
FTCPConnection.StopAccepting(true);
end;
constructor TFpDebugTcpServer.create(ADebugThread: TFpDebugThread);
begin
FDebugThread:=ADebugThread;
FConnectionList:=TConnectionList.Create(false);
inherited Create(false);
end;
procedure TFpDebugTcpServer.RemoveConnection(ADebugTcpConnectionThread: TFpDebugTcpConnectionThread);
begin
FConnectionList.Remove(ADebugTcpConnectionThread);
end;
destructor TFpDebugTcpServer.Destroy;
var
i: integer;
begin
for i := 0 to FConnectionList.Count-1 do
FConnectionList[i].Terminate;
for i := 0 to FConnectionList.Count-1 do
FConnectionList[i].WaitFor;
if FConnectionList.Count<>0 then
raise exception.create('Not all connections are cleared.');
FConnectionList.Free;
inherited Destroy;
end;
end.

410
components/fpdebug/app/fpdserver/debugthread.pas Normal file
View File

@ -0,0 +1,410 @@
unit debugthread;
{$mode objfpc}{$H+}
{$INTERFACES CORBA}
interface
uses
Classes,
SysUtils,
FPDbgController,
DbgIntfBaseTypes,
DbgIntfDebuggerBase,
lazfglhash,
fpjson,
FpDbgClasses;
type
// The debug-thread sends three different kind of messages to it's listeners
TFpDebugEventType = (
etEvent, // Messages that are send by the debugger. (debuggee has been started, pauzed, stopped, etc.)
etLog, // Log-messages send by the debugger. (Fpdebug also uses log-messages to inform users of some
// events (the dllInfo-log messages)
etNotification // Messages from the debug-thread itself. Including new or lost connections and commands that
// are queued or executed.
);
// The different kinds of etNotifications
TFpDebugNotificationType = (
ntNewConnection,
ntLostConnection,
ntInvalidCommand,
ntConnectionProblem,
ntReceivedCommand,
ntExecutedCommand,
ntFailedCommand
);
// This record is used to pass debugging-events. Not every field is applicable for each type of event.
TFpDebugEvent = record
SendByConnectionIdentifier: integer;
EventType: TFpDebugEventType;
NotificationType: TFpDebugNotificationType;
Message: string;
EventName: string;
LogLevel: TFPDLogLevel;
InstructionPointerRegValue: TDBGPtr;
AnUID: variant;
BreakpointAddr: TDBGPtr;
LocationRec: TDBGLocationRec;
end;
// Each listener should implement this interface.
IFpDebugListener = interface ['{2230763A-672E-4EC1-941D-6B8814D789C8}']
// This procedure is called by the debugthread when there is a message for the listener.
// Not that this procedure will be called from within the debug-thread, and should not take too much
// resources, or ot will slow down the debugging.
procedure SendEvent(AnEvent: TFpDebugEvent);
// Gives more information about the origin of the listener.
function GetOrigin: string;
end;
TFpDebugThread = class;
{ TFpDebugThreadCommand }
// The base class for all commands that can be send to the debug-thread.
TFpDebugThreadCommand = class
private
FOnLog: TOnLog;
protected
FListenerIdentifier: integer;
FUID: variant;
procedure Log(const AString: string; const ALogLevel: TFPDLogLevel);
public
constructor Create(AListenerIdentifier: integer; AnUID: variant; AOnLog: TOnLog); virtual;
// Descendents may override this procedure to add additionol information to the event that will
// be send to all listeners when a command has been received succesfully
procedure ComposeReceiveEvent(var AnEvent: TFpDebugEvent); virtual;
// As above, for commands that has been executed successfully
procedure ComposeSuccessEvent(var AnEvent: TFpDebugEvent); virtual;
// As above, for commands that has failed to execute.
procedure ComposeFailureEvent(var AnEvent: TFpDebugEvent); virtual;
// Descendents have to override this function to implement the actual command. This function is called from within
// the debug-controller's debug loop. (This means it is only executed when the debuggee is paused or stopped)
// Should return tru on success, false on a failure. Set DoProcessLoop to true when the debuggee should continue,
// make it false if the debuggee should stay in a paused state.
function Execute(AController: TDbgController; out DoProcessLoop: boolean): boolean; virtual; abstract;
// The name that is used to identify the command
class function TextName: string; virtual; abstract;
// The identifier of the Listener that has send this command
property ListenerIdentifier: integer read FListenerIdentifier;
end;
TFpDebugThreadCommandClass = class of TFpDebugThreadCommand;
{ TFpDebugThread }
TFpDebugThread = class(TThread)
private
FCommandQueue: TThreadList;
FController: TDbgController;
FListenerList: TThreadList;
protected
// Handlers for the FController-events
procedure FControllerHitBreakpointEvent(var continue: boolean; const Breakpoint: TDbgBreakpoint);
procedure FControllerProcessExitEvent(ExitCode: DWord);
procedure FControllerCreateProcessEvent(var continue: boolean);
// Main debug thread-loop
procedure Execute; override;
// Send an event to all listeners
procedure SendEvent(ADebugEvent: TFpDebugEvent);
procedure ClearEvent(var AnEvent: TFpDebugEvent);
public
constructor Create;
destructor Destroy; override;
class function Instance: TFpDebugThread;
// Sends a command to the command-queue, the command-queue takes ownership of the command.
procedure QueueCommand(ACommand: TFpDebugThreadCommand);
// Procedures to send notifications and log-messages to the listeners
procedure SendNotification(AConnectionIdentifier: integer; ANotificationType: TFpDebugNotificationType; AnUID: variant; AMessage, ACommand: string);
procedure SendNotification(AConnectionIdentifier: integer; ANotificationType: TFpDebugNotificationType; AnUID: variant; AMessage, ACommand: string; Arg: array of const); overload;
procedure SendLogMessage(const AString: string; const ALogLevel: TFPDLogLevel);
// Methods to add and remove listeners
function AddListener(AFpDebugListener: IFpDebugListener): integer;
procedure RemoveListener(AFpDebugListener: IFpDebugListener);
end;
const
FpEventTypeNames: array[TFpDebugEventType] of string = (
'event',
'log',
'notification');
FpDebugNotificationTypeNames: array[TFpDebugNotificationType] of string = (
'NewConnection',
'LostConnection',
'InvalidCommand',
'ConnectionProblem',
'ReceivedCommand',
'ExecutedCommand',
'FailedCommand');
implementation
var
FFpDebugThread: TFpDebugThread;
{ TFpDebugThreadCommand }
procedure TFpDebugThreadCommand.Log(const AString: string; const ALogLevel: TFPDLogLevel);
begin
if assigned(FOnLog) then
FOnLog(AString, ALogLevel);
end;
constructor TFpDebugThreadCommand.Create(AListenerIdentifier: integer;
AnUID: variant; AOnLog: TOnLog);
begin
FListenerIdentifier:=AListenerIdentifier;
FUID:=AnUID;
FOnLog:=AOnLog;
end;
procedure TFpDebugThreadCommand.ComposeReceiveEvent(var AnEvent: TFpDebugEvent);
begin
AnEvent.EventType:=etNotification;
AnEvent.NotificationType:=ntReceivedCommand;
AnEvent.SendByConnectionIdentifier:=ListenerIdentifier;
AnEvent.AnUID:=FUID;
AnEvent.EventName:=TextName;
AnEvent.Message:=Format('Received %s-command.',[TextName]);
end;
procedure TFpDebugThreadCommand.ComposeSuccessEvent(var AnEvent: TFpDebugEvent);
begin
AnEvent.EventType:=etNotification;
AnEvent.NotificationType:=ntExecutedCommand;
AnEvent.SendByConnectionIdentifier:=ListenerIdentifier;
AnEvent.AnUID:=FUID;
AnEvent.EventName:=TextName;
AnEvent.Message:=Format('%s-command executed succesfully.',[TextName]);
end;
procedure TFpDebugThreadCommand.ComposeFailureEvent(var AnEvent: TFpDebugEvent);
begin
AnEvent.EventType:=etNotification;
AnEvent.NotificationType:=ntFailedCommand;
AnEvent.SendByConnectionIdentifier:=ListenerIdentifier;
AnEvent.AnUID:=FUID;
AnEvent.EventName:=TextName;
AnEvent.Message:=Format('%s-command failed.',[TextName]);
end;
{ TFpDebugThread }
procedure TFpDebugThread.SendLogMessage(const AString: string; const ALogLevel: TFPDLogLevel);
var
ADebugEvent: TFpDebugEvent;
begin
ClearEvent(ADebugEvent);
ADebugEvent.EventType:=etLog;
ADebugEvent.Message:=AString;
ADebugEvent.LogLevel:=ALogLevel;
SendEvent(ADebugEvent);
end;
procedure TFpDebugThread.ClearEvent(var AnEvent: TFpDebugEvent);
begin
AnEvent.AnUID:=null;
AnEvent.SendByConnectionIdentifier:=-1;
AnEvent.InstructionPointerRegValue:=0;
AnEvent.BreakpointAddr:=0;
AnEvent.LocationRec.Address:=0;
end;
procedure TFpDebugThread.FControllerHitBreakpointEvent(var continue: boolean; const Breakpoint: TDbgBreakpoint);
var
ADebugEvent: TFpDebugEvent;
begin
ClearEvent(ADebugEvent);
ADebugEvent.EventType:=etEvent;
ADebugEvent.EventName:='BreakPoint';
ADebugEvent.InstructionPointerRegValue:=FController.CurrentProcess.GetInstructionPointerRegisterValue;
if assigned(Breakpoint) then
ADebugEvent.BreakpointAddr:=Breakpoint.Location;
SendEvent(ADebugEvent);
continue:=false;
end;
procedure TFpDebugThread.FControllerProcessExitEvent(ExitCode: DWord);
var
ADebugEvent: TFpDebugEvent;
begin
ClearEvent(ADebugEvent);
ADebugEvent.EventType:=etEvent;
ADebugEvent.EventName:='ExitProcess';
ADebugEvent.InstructionPointerRegValue:=FController.CurrentProcess.GetInstructionPointerRegisterValue;
SendEvent(ADebugEvent);
end;
procedure TFpDebugThread.FControllerCreateProcessEvent(var continue: boolean);
var
ADebugEvent: TFpDebugEvent;
begin
ClearEvent(ADebugEvent);
ADebugEvent.EventType:=etEvent;
ADebugEvent.EventName:='CreateProcess';
ADebugEvent.InstructionPointerRegValue:=FController.CurrentProcess.GetInstructionPointerRegisterValue;
SendEvent(ADebugEvent);
continue:=false;
end;
procedure TFpDebugThread.Execute;
var
AList: TList;
ACommand: TFpDebugThreadCommand;
ARunLoop: boolean;
AnEvent: TFpDebugEvent;
begin
FController := TDbgController.Create;
FController.OnCreateProcessEvent:=@FControllerCreateProcessEvent;
FController.OnProcessExitEvent:=@FControllerProcessExitEvent;
FController.OnHitBreakpointEvent:=@FControllerHitBreakpointEvent;
FController.OnLog:=@SendLogMessage;
try
repeat
try
ACommand:=nil;
AList := FCommandQueue.LockList;
try
if AList.Count>0 then
begin
ACommand:=TFpDebugThreadCommand(AList.Items[0]);
AList.Delete(0);
end;
finally
FCommandQueue.UnlockList;
end;
if assigned(ACommand) then
begin
try
ClearEvent(AnEvent);
ACommand.ComposeReceiveEvent(AnEvent);
SendEvent(AnEvent);
if ACommand.Execute(FController, ARunLoop) then
begin
ClearEvent(AnEvent);
ACommand.ComposeSuccessEvent(AnEvent);
SendEvent(AnEvent);
end
else
begin
ClearEvent(AnEvent);
ACommand.ComposeFailureEvent(AnEvent);
SendEvent(AnEvent);
end;
finally
ACommand.Free;
end;
while ARunLoop do
begin
FController.ProcessLoop;
FController.SendEvents(ARunLoop);
end;
end;
sleep(100);
except
on E: Exception do
writeln('Exception in debug-thread: '+e.Message); // just continue
end;
until terminated;
finally
FController.Free;
end;
end;
procedure TFpDebugThread.SendEvent(ADebugEvent: TFpDebugEvent);
var
i: integer;
AList: TList;
begin
AList:=FListenerList.LockList;
try
for i := 0 to AList.Count-1 do
begin
IFpDebugListener(AList[i]).SendEvent(ADebugEvent);
end;
finally
FListenerList.UnlockList;
end;
end;
constructor TFpDebugThread.Create;
begin
inherited create(false);
FCommandQueue := TThreadList.Create;
FListenerList:=TThreadList.Create;
end;
destructor TFpDebugThread.Destroy;
begin
FListenerList.Free;
FCommandQueue.Free;
inherited Destroy;
end;
class function TFpDebugThread.Instance: TFpDebugThread;
begin
if not assigned(FFpDebugThread) then
FFpDebugThread:=TFpDebugThread.Create;
result := FFpDebugThread;
end;
procedure TFpDebugThread.QueueCommand(ACommand: TFpDebugThreadCommand);
begin
FCommandQueue.Add(ACommand);
end;
procedure TFpDebugThread.SendNotification(AConnectionIdentifier: integer; ANotificationType: TFpDebugNotificationType; AnUID: variant; AMessage, ACommand: string);
var
AnEvent: TFpDebugEvent;
begin
ClearEvent(AnEvent);
AnEvent.SendByConnectionIdentifier:=AConnectionIdentifier;
AnEvent.EventType:=etNotification;
AnEvent.NotificationType:=ANotificationType;
anEvent.EventName:=ACommand;
AnEvent.Message:=AMessage;
AnEvent.AnUID:=AnUID;
SendEvent(AnEvent);
end;
procedure TFpDebugThread.SendNotification(AConnectionIdentifier: integer; ANotificationType: TFpDebugNotificationType; AnUID: variant; AMessage, ACommand: string;
Arg: array of const);
begin
SendNotification(AConnectionIdentifier, ANotificationType, AnUID, format(AMessage, Arg), ACommand);
end;
var
GIdentifierCount: integer = 0;
function TFpDebugThread.AddListener(AFpDebugListener: IFpDebugListener): integer;
begin
inc(GIdentifierCount);
result := GIdentifierCount;
SendNotification(result, ntNewConnection, null, 'New connection from %s', '',[AFpDebugListener.GetOrigin]);
FListenerList.Add(AFpDebugListener);
end;
procedure TFpDebugThread.RemoveListener(AFpDebugListener: IFpDebugListener);
begin
FListenerList.Remove(AFpDebugListener);
end;
initialization
FFpDebugThread := nil;
finalization
FFpDebugThread.Free;
end.

404
components/fpdebug/app/fpdserver/debugthreadcommand.pas Normal file
View File

@ -0,0 +1,404 @@
unit DebugThreadCommand;
{$mode objfpc}{$H+}
interface
uses
Classes,
contnrs,
FPDbgController,
FpDbgClasses,
FpDbgUtil,
FpDbgInfo,
DbgIntfDebuggerBase,
DbgIntfBaseTypes,
strutils,
debugthread,
SysUtils;
type
{ TFpDebugThreadCommandList }
TFpDebugThreadCommandList = class(TFPList)
public
class function instance: TFpDebugThreadCommandList;
function GetCommandByName(ATextName: string): TFpDebugThreadCommandClass;
end;
{ TFpDebugThreadSetFilenameCommand }
TFpDebugThreadSetFilenameCommand = class(TFpDebugThreadCommand)
private
FFileName: string;
public
function Execute(AController: TDbgController; out DoProcessLoop: boolean): boolean; override;
class function TextName: string; override;
published
property Filename: string read FFileName write FFileName;
end;
{ TFpDebugThreadRunCommand }
TFpDebugThreadRunCommand = class(TFpDebugThreadCommand)
public
function Execute(AController: TDbgController; out DoProcessLoop: boolean): boolean; override;
class function TextName: string; override;
end;
{ TFpDebugThreadContinueCommand }
TFpDebugThreadContinueCommand = class(TFpDebugThreadCommand)
public
function Execute(AController: TDbgController; out DoProcessLoop: boolean): boolean; override;
class function TextName: string; override;
end;
{ TFpDebugThreadNextCommand }
TFpDebugThreadNextCommand = class(TFpDebugThreadCommand)
public
function Execute(AController: TDbgController; out DoProcessLoop: boolean): boolean; override;
class function TextName: string; override;
end;
{ TFpDebugThreadStepCommand }
TFpDebugThreadStepCommand = class(TFpDebugThreadCommand)
public
function Execute(AController: TDbgController; out DoProcessLoop: boolean): boolean; override;
class function TextName: string; override;
end;
{ TFpDebugThreadStepOutCommand }
TFpDebugThreadStepOutCommand = class(TFpDebugThreadCommand)
public
function Execute(AController: TDbgController; out DoProcessLoop: boolean): boolean; override;
class function TextName: string; override;
end;
{ TFpDebugThreadStepIntoInstrCommand }
TFpDebugThreadStepIntoInstrCommand = class(TFpDebugThreadCommand)
public
function Execute(AController: TDbgController; out DoProcessLoop: boolean): boolean; override;
class function TextName: string; override;
end;
{ TFpDebugThreadStepOverInstrCommand }
TFpDebugThreadStepOverInstrCommand = class(TFpDebugThreadCommand)
public
function Execute(AController: TDbgController; out DoProcessLoop: boolean): boolean; override;
class function TextName: string; override;
end;
{ TFpDebugThreadStopCommand }
TFpDebugThreadStopCommand = class(TFpDebugThreadCommand)
public
function Execute(AController: TDbgController; out DoProcessLoop: boolean): boolean; override;
class function TextName: string; override;
end;
{ TFpDebugThreadAddBreakpointCommand }
TFpDebugThreadAddBreakpointCommand = class(TFpDebugThreadCommand)
private
FFileName: string;
FLine: integer;
FBreakPoint: FpDbgClasses.TDbgBreakpoint;
public
procedure ComposeSuccessEvent(var AnEvent: TFpDebugEvent); override;
function Execute(AController: TDbgController; out DoProcessLoop: boolean): boolean; override;
class function TextName: string; override;
published
property Filename: string read FFileName write FFileName;
property Line: integer read FLine write FLine;
end;
{ TFpDebugThreadGetLocationInfoCommand }
TFpDebugThreadGetLocationInfoCommand = class(TFpDebugThreadCommand)
private
FLocationRec: TDBGLocationRec;
FAddressValue: TDBGPtr;
function GetAddress: string;
procedure SetAddress(AValue: string);
protected
procedure ComposeSuccessEvent(var AnEvent: TFpDebugEvent); override;
public
function Execute(AController: TDbgController; out DoProcessLoop: boolean): boolean; override;
class function TextName: string; override;
published
property Address: string read GetAddress write SetAddress;
end;
implementation
{ TFpDebugThreadCommandList }
var
GFpDebugThreadCommandList: TFpDebugThreadCommandList = nil;
{ TFpDebugThreadStopCommand }
function TFpDebugThreadStopCommand.Execute(AController: TDbgController; out
DoProcessLoop: boolean): boolean;
begin
AController.Stop;
DoProcessLoop:=true;
result := true;
end;
class function TFpDebugThreadStopCommand.TextName: string;
begin
result := 'stop';
end;
{ TFpDebugThreadStepOutCommand }
function TFpDebugThreadStepOutCommand.Execute(AController: TDbgController; out
DoProcessLoop: boolean): boolean;
begin
AController.StepOut;
DoProcessLoop:=true;
result := true;
end;
class function TFpDebugThreadStepOutCommand.TextName: string;
begin
result := 'stepout';
end;
{ TFpDebugThreadStepOverInstrCommand }
function TFpDebugThreadStepOverInstrCommand.Execute(
AController: TDbgController; out DoProcessLoop: boolean): boolean;
begin
AController.StepOverInstr;
DoProcessLoop:=true;
result := true;
end;
class function TFpDebugThreadStepOverInstrCommand.TextName: string;
begin
result := 'stepoverinstr';
end;
{ TFpDebugThreadStepIntoInstrCommand }
function TFpDebugThreadStepIntoInstrCommand.Execute(
AController: TDbgController; out DoProcessLoop: boolean): boolean;
begin
AController.StepIntoInstr;
DoProcessLoop:=true;
result := true;
end;
class function TFpDebugThreadStepIntoInstrCommand.TextName: string;
begin
result := 'stepintoinstr';
end;
{ TFpDebugThreadStepCommand }
function TFpDebugThreadStepCommand.Execute(AController: TDbgController; out
DoProcessLoop: boolean): boolean;
begin
AController.Step;
DoProcessLoop:=true;
result := true;
end;
class function TFpDebugThreadStepCommand.TextName: string;
begin
result := 'step';
end;
{ TFpDebugThreadNextCommand }
function TFpDebugThreadNextCommand.Execute(AController: TDbgController; out
DoProcessLoop: boolean): boolean;
begin
AController.Next;
DoProcessLoop:=true;
result := true;
end;
class function TFpDebugThreadNextCommand.TextName: string;
begin
result := 'next';
end;
{ TFpDebugThreadGetLocationInfoCommand }
function TFpDebugThreadGetLocationInfoCommand.GetAddress: string;
begin
result := FormatAddress(FAddressValue);
end;
procedure TFpDebugThreadGetLocationInfoCommand.SetAddress(AValue: string);
begin
FAddressValue := Hex2Dec(AValue);
end;
procedure TFpDebugThreadGetLocationInfoCommand.ComposeSuccessEvent(var AnEvent: TFpDebugEvent);
begin
inherited ComposeSuccessEvent(AnEvent);
AnEvent.LocationRec:=FLocationRec;
end;
function TFpDebugThreadGetLocationInfoCommand.Execute(AController: TDbgController; out DoProcessLoop: boolean): boolean;
var
sym, symproc: TFpDbgSymbol;
begin
DoProcessLoop:=false;
result := false;
if Assigned(AController.CurrentProcess) then
begin
FLocationRec.FuncName:='';
FLocationRec.SrcFile:='';
FLocationRec.SrcFullName:='';
FLocationRec.SrcLine:=0;
if FAddressValue=0 then
FLocationRec.Address := AController.CurrentProcess.GetInstructionPointerRegisterValue
else
FLocationRec.Address := FAddressValue;
sym := AController.CurrentProcess.FindSymbol(FLocationRec.Address);
if sym = nil then
Exit;
FLocationRec.SrcFile := ExtractFileName(sym.FileName);
FLocationRec.SrcLine := sym.Line;
FLocationRec.SrcFullName := sym.FileName;
symproc := sym;
while not (symproc.kind in [skProcedure, skFunction]) do
symproc := symproc.Parent;
if assigned(symproc) then
FLocationRec.FuncName:=symproc.Name;
sym.free;
result := true;
end;
end;
class function TFpDebugThreadGetLocationInfoCommand.TextName: string;
begin
result := 'getlocationinfo'
end;
{ TFpDebugThreadAddBreakpointCommand }
procedure TFpDebugThreadAddBreakpointCommand.ComposeSuccessEvent(var AnEvent: TFpDebugEvent);
begin
inherited ComposeSuccessEvent(AnEvent);
AnEvent.BreakpointAddr:=FBreakPoint.Location;
end;
function TFpDebugThreadAddBreakpointCommand.Execute(AController: TDbgController; out DoProcessLoop: boolean): boolean;
begin
result := false;
DoProcessLoop:=false;
if not assigned(AController.CurrentProcess) then
begin
log('Failed to add breakpoint: No process', dllInfo);
exit;
end;
if (Filename<>'') and (line>-1) then
begin
FBreakPoint := AController.CurrentProcess.AddBreak(FileName, Line);
result := assigned(FBreakPoint);
end
else
log('Failed to add breakpoint: No filename and line-number given', dllInfo);
end;
class function TFpDebugThreadAddBreakpointCommand.TextName: string;
begin
result := 'breakpoint';
end;
class function TFpDebugThreadCommandList.instance: TFpDebugThreadCommandList;
begin
if not assigned(GFpDebugThreadCommandList) then
GFpDebugThreadCommandList := TFpDebugThreadCommandList.Create;
result := GFpDebugThreadCommandList;
end;
function TFpDebugThreadCommandList.GetCommandByName(ATextName: string): TFpDebugThreadCommandClass;
var
i: Integer;
begin
result := nil;
for i := 0 to count -1 do
begin
if TFpDebugThreadCommandClass(Items[i]).TextName=ATextName then
result := TFpDebugThreadCommandClass(Items[i]);
end;
end;
{ TFpDebugThreadContinueCommand }
function TFpDebugThreadContinueCommand.Execute(AController: TDbgController; out
DoProcessLoop: boolean): boolean;
begin
DoProcessLoop:=true;
result := true;
end;
class function TFpDebugThreadContinueCommand.TextName: string;
begin
result := 'continue';
end;
{ TFpDebugThreadRunCommand }
function TFpDebugThreadRunCommand.Execute(AController: TDbgController; out
DoProcessLoop: boolean): boolean;
begin
DoProcessLoop := AController.Run;
result := DoProcessLoop;
end;
class function TFpDebugThreadRunCommand.TextName: string;
begin
result := 'run';
end;
{ TFpDebugThreadSetFilenameCommand }
function TFpDebugThreadSetFilenameCommand.Execute(AController: TDbgController;
out DoProcessLoop: boolean): boolean;
begin
AController.ExecutableFilename:=FFileName;
DoProcessLoop:=false;
result:=true;
end;
class function TFpDebugThreadSetFilenameCommand.TextName: string;
begin
result := 'filename'
end;
initialization
TFpDebugThreadCommandList.instance.Add(TFpDebugThreadSetFilenameCommand);
TFpDebugThreadCommandList.instance.Add(TFpDebugThreadRunCommand);
TFpDebugThreadCommandList.instance.Add(TFpDebugThreadContinueCommand);
TFpDebugThreadCommandList.instance.Add(TFpDebugThreadStepOverInstrCommand);
TFpDebugThreadCommandList.instance.Add(TFpDebugThreadStepIntoInstrCommand);
TFpDebugThreadCommandList.instance.Add(TFpDebugThreadNextCommand);
TFpDebugThreadCommandList.instance.Add(TFpDebugThreadStepCommand);
TFpDebugThreadCommandList.instance.Add(TFpDebugThreadStepOutCommand);
TFpDebugThreadCommandList.instance.Add(TFpDebugThreadStopCommand);
TFpDebugThreadCommandList.instance.Add(TFpDebugThreadAddBreakpointCommand);
TFpDebugThreadCommandList.instance.Add(TFpDebugThreadGetLocationInfoCommand);
finalization
GFpDebugThreadCommandList.Free;
end.

105
components/fpdebug/app/fpdserver/fpdserver.lpi Normal file
View File

@ -0,0 +1,105 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<General>
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="FPD Server"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="LazUtils"/>
</Item1>
<Item2>
<PackageName Value="fpdebug"/>
</Item2>
</RequiredPackages>
<Units Count="5">
<Unit0>
<Filename Value="fpdserver.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="debugthread.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="debugthread"/>
</Unit1>
<Unit2>
<Filename Value="debugthreadcommand.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="DebugThreadCommand"/>
</Unit2>
<Unit3>
<Filename Value="debugtcpserver.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="DebugTCPServer"/>
</Unit3>
<Unit4>
<Filename Value="debuginoutputprocessor.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="DebugInOutputProcessor"/>
</Unit4>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="fpdserver"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Debugging>
<UseHeaptrc Value="True"/>
</Debugging>
<Options>
<PassLinkerOptions Value="True"/>
<LinkerOptions Value="-sectcreate __TEXT __info_plist Info.plist"/>
</Options>
</Linking>
<Other>
<ExecuteAfter>
<Command Value="codesign -s fpdebug fpdserver"/>
<CompileReasons Run="False"/>
</ExecuteAfter>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

197
components/fpdebug/app/fpdserver/fpdserver.lpr Normal file
View File

@ -0,0 +1,197 @@
program fpdserver;
{ FPDebug server
Copyright (C) 2015 Joost van der Sluis joost@cnoc.nl
This source is free software; you can redistribute it and/or modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later
version.
This code 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. See the GNU General Public License for more
details.
A copy of the GNU General Public License is available on the World Wide Web at
<http://www.gnu.org/copyleft/gpl.html>. You can also obtain it by writing to the Free Software Foundation, Inc., 59
Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}
cthreads,
{$ENDIF}
Classes,
SysUtils,
CustApp,
syncobjs,
pipes,
lazfglhash,
debugthread,
DebugThreadCommand,
lazCollections,
DebugInOutputProcessor,
DebugTCPServer;
type
TFpDebugEventQueue = specialize TLazThreadedQueue<TFpDebugEvent>;
{ TFPDServerApplication }
TFPDServerApplication = class(TCustomApplication, IFpDebugListener)
private
FEventQueue: TFpDebugEventQueue;
FInOutputProcessor: TCustomInOutputProcessor;
FConnectionIdentifier: integer;
protected
procedure DoRun; override;
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
procedure WriteHelp; virtual;
// IFpDebugListener
procedure SendEvent(AnEvent: TFpDebugEvent);
function GetOrigin: string;
end;
{ TFPDServerApplication }
procedure TFPDServerApplication.DoRun;
var
ErrorMsg: String;
DebugThread: TFpDebugThread;
DebugEvent: TFpDebugEvent;
InputStream: TInputPipeStream;
CommandStr: string;
TCPServerThread: TFpDebugTcpServer;
ACommand: TFpDebugThreadCommand;
b: char;
begin
// quick check parameters
ErrorMsg:=CheckOptions('hf', ['help']);
if ErrorMsg<>'' then
begin
ShowException(Exception.Create(ErrorMsg));
Terminate;
Exit;
end;
// parse parameters
if HasOption('h', 'help') then
begin
WriteHelp;
Terminate;
Exit;
end;
DebugThread := TFpDebugThread.Instance;
TCPServerThread := TFpDebugTcpServer.Create(DebugThread);
if HasOption('f') then
begin
CommandStr := GetOptionValue('f');
if CommandStr<>'' then
begin
ACommand := TFpDebugThreadSetFilenameCommand.create(-1, null, @DebugThread.SendLogMessage);
TFpDebugThreadSetFilenameCommand(ACommand).Filename:=CommandStr;
DebugThread.QueueCommand(ACommand);
end
else
begin
WriteHelp;
Terminate;
end;
CommandStr:='';
end;
InputStream:=TInputPipeStream.Create(StdInputHandle);
FConnectionIdentifier := DebugThread.AddListener(self);
FInOutputProcessor := TJSonInOutputProcessor.create(FConnectionIdentifier, @DebugThread.SendLogMessage);
try
while not terminated do
begin
if FEventQueue.PopItem(DebugEvent) = wrSignaled then
begin
writeln(FInOutputProcessor.EventToText(DebugEvent));
end;
while InputStream.NumBytesAvailable>0 do
begin
InputStream.Read(b,sizeof(b));
if b <> #10 then
CommandStr:=CommandStr+b
else
begin
if CommandStr='q' then
Terminate
else
begin
ACommand := FInOutputProcessor.TextToCommand(CommandStr);
if assigned(ACommand) then
DebugThread.QueueCommand(ACommand);
end;
CommandStr:='';
end;
end;
CheckSynchronize;
end;
DebugThread.RemoveListener(self);
finally
FInOutputProcessor.Free;
end;
TCPServerThread.StopListening;
TCPServerThread.WaitFor;
TCPServerThread.Free;
DebugThread.Terminate;
DebugThread.WaitFor;
InputStream.Free;
terminate;
end;
constructor TFPDServerApplication.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
FEventQueue:=TFpDebugEventQueue.Create(100, INFINITE, 100);
StopOnException:=True;
end;
destructor TFPDServerApplication.Destroy;
begin
FEventQueue.Free;
inherited Destroy;
end;
procedure TFPDServerApplication.SendEvent(AnEvent: TFpDebugEvent);
begin
FEventQueue.PushItem(AnEvent);
end;
function TFPDServerApplication.GetOrigin: string;
begin
result := 'console';
end;
procedure TFPDServerApplication.WriteHelp;
begin
{ add your help code here }
writeln('Usage: ', ExeName, ' --help -h -f <executable name>');
end;
var
Application: TFPDServerApplication;
begin
Application:=TFPDServerApplication.Create(nil);
Application.Title:='FPD Server';
Application.Run;
Application.Free;
end.

22
components/fpdebug/app/fpdserver/readme.txt Normal file
View File

@ -0,0 +1,22 @@
FPDebug-Server
The FPDebug-server contains a single fpdebug-thread to be able to debug one application at a time.
Multiple listeners can attach to this debug-thread so that they will receive messages from the fpdebug-thread about
the application being debugged.
The listeners can also send commands to the debug-thread, all listeners will receive information about all comands.
By default there are two listeners, one to communicate with the console. That way the debugger can be controlled from
the console. The other listener is setting up a tcp-server listening on port 9001. It's possible to connect to this
port using telnet to control the debugging.
In- and output are in a a json-format, but it is possible to register multiple formats.
The FPDebug-server could be used as a stand-alone debugger, controlled using the console. Or it could be used by other
front-ends using the tcp-listener. Multiple connections can be used to monitor what is happening.
The goal is to add a Lazarus as a front end. It can be used for remote-debugging, and it can be used to avoid the
necessity to sign the Lazarus-executable to be able to debug on OS/X. (Only the FPDebug-server has to be signed)
Joost van der Sluis, may 2015.