+ Initial implementation

utils/debugsvr/Makefile.fpc

@@ -0,0 +1,27 @@
+#
+#   Makefile.fpc for debugserver
+#
+
+[target]
+units=msgintf debugserverintf dbugintf
+dirs=gtk console
+examples=testdebug speeddebug
+rsts=debugserverintf dbugintf
+
+[clean]
+
+[compiler]
+
+[install]
+fpcpackage=y
+
+[default]
+fpcdir=../..
+
+
+[rules]
+debugserverintf$(PPUEXT): msgintf$(PPUEXT) debugserverintf.pp
+        $(COMPILER) debugserverintf$(PASEXT)
+
+dbugintf$(PPUEXT): msgintf$(PPUEXT) dbugintf.pp
+        $(COMPILER) dbugintf.pp

utils/debugsvr/dbugintf.pp

@@ -0,0 +1,290 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2003 by the Free Pascal development team
+
+    User interface for debug server.
+    
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+{$ifdef fpc}
+{$mode objfpc}
+{$h+}
+{$endif}
+unit dbugintf;
+
+
+interface
+
+uses 
+{$ifdef fpc}
+   linux,
+{$else}
+   Libc,
+{$endif}
+   msgintf,
+   classes,
+   ssockets;
+
+Type
+  TDebugLevel = (dlInformation,dlWarning,dlError);
+  
+{$ifdef fpc}
+  pid_t = longint;
+{$endif}
+
+procedure SendBoolean(const Identifier: string; const Value: Boolean);
+procedure SendDateTime(const Identifier: string; const Value: TDateTime);
+procedure SendDebugEx(const Msg: string; MType: TDebugLevel);
+procedure SendDebug(const Msg: string);
+procedure SendInteger(const Identifier: string; const Value: Integer);
+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);
+ 
+{ low-level routines }
+
+procedure SendDebugMessage(Const Msg : TDebugMessage);
+function  CreateDebugStream : TStream;
+function  StartDebugServer : pid_t;
+Procedure InitDebugStream;
+
+Const
+  SendError       : String = '';
+  
+ResourceString
+  SProcessID = 'Process %d: %s';
+  SEntering = '> Entering ';
+  SExiting  = '< Exiting ';
+  SSeparator = '>-=-=-=-=-=-=-=-=-=-=-=-=-=-=-<';
+
+implementation
+
+Uses SysUtils,process;
+//     UnixProcessUtils;
+
+Const
+  DmtInformation = lctInformation;
+  DmtWarning     = lctWarning;
+  DmtError       = lctError;
+  ErrorLevel     : Array[TDebugLevel] of integer
+                 = (dmtInformation,dmtWarning,dmtError);
+
+Const
+  DebugStream : TStream = nil;
+
+Procedure WriteMessage(S : TStream; Const Msg : TDebugMessage);
+
+Var
+  MsgSize : Integer;
+
+begin
+  S.WriteBuffer(Msg.MsgType,SizeOf(Integer));
+  S.WriteBuffer(Msg.MsgTimeStamp,SizeOf(TDateTime));
+  MsgSize:=Length(Msg.Msg);
+  S.WriteBuffer(MsgSize,SizeOf(Integer));
+  S.WriteBuffer(Msg.msg[1],MsgSize);
+end;
+
+procedure SendDebugMessage(Const Msg : TDebugMessage);
+
+begin
+  try
+    If DebugStream=Nil then
+      begin
+      InitDebugStream;
+      end;
+    WriteMessage(debugStream,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 SendDebugEx(const Msg: string; MType: TDebugLevel);
+
+Var
+  Mesg : TDebugMessage;
+
+begin
+  Mesg.MsgTimeStamp:=Now;
+  Mesg.MsgType:=ErrorLevel[MTYpe];
+  Mesg.Msg:=Msg;
+  SendDebugMessage(Mesg);
+end;
+
+procedure SendDebug(const Msg: string);
+
+Var
+  Mesg : TDebugMessage;
+begin
+  Mesg.MsgTimeStamp:=Now;
+  Mesg.MsgType:=dmtInformation;
+  Mesg.Msg:=Msg;
+  SendDebugMessage(Mesg);
+end;
+
+procedure SendInteger(const Identifier: string; const Value: Integer);
+
+begin
+  SendDebugFmt('%s = %d',[identifier,Value]);
+end;
+
+procedure SendMethodEnter(const MethodName: string);
+
+begin
+  SendDebug(SEntering+MethodName);
+end;
+
+procedure SendMethodExit(const MethodName: string);
+
+begin
+  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:=dmtInformation;
+  Mesg.Msg:=Format(Msg,Args);
+  SendDebugMessage(Mesg);
+end;
+
+procedure SendDebugFmtEx(const Msg: string; const Args: array of const; MType: TDebugLevel);
+
+Var
+  Mesg : TDebugMessage;
+
+begin
+  Mesg.MsgTimeStamp:=Now;
+  Mesg.MsgType:=ErrorLevel[mType];
+  Mesg.Msg:=Format(Msg,Args);
+  SendDebugMessage(Mesg);
+end;
+
+function StartDebugServer : pid_t;
+
+begin
+  With TProcess.Create(Nil) do
+    Try
+      CommandLine:='debugserver';
+      Execute;
+    Finally
+      Free;
+    end;
+end;
+
+function CreateUnixDebugStream(SocketFile : String) : TStream;
+
+{$ifdef fpc}
+Var
+  tv,tr : timespec;
+{$endif}
+
+begin
+    If Not FileExists(DebugSocket) then
+      begin
+      StartDebugServer;
+{$ifndef fpc}
+      sleep(1000);
+{$else}
+      tv.tv_sec:=1;
+      tv.tv_nsec:=0;
+      nanosleep(tv,tr);
+{$endif}        
+      end;
+{$ifdef fpc}
+  Result:=TUnixSocket.Create(SocketFile);
+{$else}
+  Result:=TUnixSocket.CreateFromFile(SocketFile);
+{$endif}  
+end;
+
+Function CreateInetDebugStream (HostName : String; Port : Word) : TStream;
+
+begin
+  Result:=TInetSocket.Create(HostName,Port);
+end;
+
+
+function CreateDebugStream : TStream;
+
+Var
+  Msg : TDebugMessage;
+
+begin
+  Case DebugConnection of 
+    dcUnix : Result:=CreateUnixDebugStream(DebugSocket);
+    dcInet : Result:=CreateInetDebugStream(DebugHostName,DebugPort);
+  end;  
+  Msg.MsgType:=lctIdentify;
+  Msg.MsgTimeStamp:=Now;
+  Msg.Msg:=Format(SProcessID,[getPID,ExtractFileName(Paramstr(0))]);
+  WriteMessage(REsult,Msg);
+end;
+
+procedure FreeDebugStream;
+
+Var i : Integer;
+
+begin
+  If (DebugStream<>Nil) then
+    try
+      i:=-1;
+      DebugStream.WriteBuffer(I,SizeOf(I));
+      DebugStream.Free;
+    except
+    end;
+end;
+
+Procedure InitDebugStream;
+
+begin
+  debugstream:=CreateDebugStream;
+end;
+
+Initialization
+
+Finalization
+  FreeDebugStream;
+end.
+
+{
+  $Log$
+  Revision 1.1  2003-01-02 14:44:29  michael
+  + Initial implementation
+
+}

utils/debugsvr/debugserverintf.pp

@@ -0,0 +1,388 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2003 by the Free Pascal development team
+
+    Interface for debug server.
+    
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+{$mode objfpc}
+{$h+}
+unit debugserverintf;
+
+Interface
+
+Uses 
+  msgintf,linux,classes,sockets,sysutils;
+
+Const 
+  MsgTypes : Array[-1..3] of string = 
+    ('Disconnect','Information','Warning','Error','Identify');
+
+
+Type
+  Thandle = Longint; // Abstraction for easier porting.
+  
+  TClient = Class(TObject)
+    Handle : THandle;
+    Peer : ShortString;
+    Data : Pointer;
+  end;
+
+  TDebugEvent = Record
+    Client : TClient;
+    LogCode : Integer;
+    TimeStamp : TDateTime;
+    Event : String;
+  end;
+  
+Var
+  FClients : TList;
+  Accepting : Boolean;
+  Quit : Boolean;
+  DebugLogCallback : Procedure (Const Event : TDebugEvent);
+  DebugObjLogCallBack : Procedure (Const Event : TDebugEvent) of Object;
+  CloseConnectionCallBack : Procedure (Client : TClient);
+  CloseObjConnectionCallBack : Procedure (Client : TClient) of Object;
+  
+   
+Procedure OpenDebugServer;
+Procedure CloseDebugServer;
+Function  ClientFromHandle (AHandle : THandle) : TClient;
+Procedure ReadMessage(Handle : THandle);
+Procedure ReadMessageEvent(Handle : THandle; Var Event : TDebugEvent);
+Function  CheckNewConnection : TClient;
+procedure CloseConnection(Client : TClient);
+Procedure CloseClientHandle(Handle : THandle);
+
+ResourceString
+  SClientLog = 'Client log %d';
+  SEvent     = 'Event';
+  SMessage   = 'Message';
+  SStopAccepting = 'Stop accepting new connections';
+  SStartAccepting = 'Start accepting new connections';
+  SErrSocketFailed = 'Creation of socket failed: %s';
+  SErrBindFailed = 'Binding of socket failed: %s';
+  SErrListenFailed = 'Listening on port #%d failed: %s';
+  SErrAcceptFailed = 'Could not accept a client connection: %d';
+  SClosingConnection = 'Closing connection.';
+  SErrFailedToSetSignalHandler = 'Failed to set signal handler.';
+  SPeerAt = 'Peer at %d';
+
+
+Implementation
+
+Function ClientFromHandle (AHandle : THandle) : TClient;
+
+Var
+  I : Longint;
+
+begin
+  Result:=Nil;
+  I:=0;
+  With FClients do 
+    While (I<Count) and (Result=Nil) do
+      Begin
+      If TClient(Items[i]).Handle=AHandle then
+        Result:=TClient(Items[i]);
+      Inc(I);
+      end;
+end;
+
+{ ---------------------------------------------------------------------
+    Communications handling: Unix Socket setup
+  ---------------------------------------------------------------------}
+  
+Var
+  FSocket : Integer;
+
+
+Procedure SetupUnixSocket;
+
+var
+  Flags,AddrLen : Integer;
+  FUnixAddr : TUnixSockAddr;
+  FFileName : String;
+  Quit : Boolean;
+     
+begin
+  FFileName:=DebugSocket;
+  FSocket:=Socket(AF_UNIX,SOCK_STREAM,0);
+  If FSocket<0 Then
+    Raise Exception.Create(SErrSocketFailed);
+  Flags:=FCntl(FSOCket,F_GETFL);
+  Flags:=Flags or Open_NONBLOCK;
+  FCntl(FSocket,F_SETFL,Flags);
+  Str2UnixSockAddr(FFilename,FUnixAddr,AddrLen);
+  If Not Bind(FSocket,FUnixAddr,AddrLen) then
+     Raise Exception.CreateFmt(SErrBindFailed,[FFileName]);
+  If Not (Listen(FSocket,5)) then
+    Raise Exception.CreateFmt(SErrListenFailed,[FSocket]);
+  FClients:=TList.Create;  
+  Accepting:=True;
+end;
+
+Procedure DestroyUnixSocket;
+
+Var
+  C : TClient;
+
+begin
+  If Assigned(FClients) then
+    begin
+    With FClients do
+      While Count>0 do
+        begin
+        C:=TClient(Items[Count-1]);
+        FileClose(C.Handle);
+        C.Free;
+        Delete(Count-1);
+        end;
+    FileClose(FSocket);
+    DeleteFile(DebugSocket);
+    end;
+end;
+
+{ ---------------------------------------------------------------------
+    Communications handling: Inet Socket setup
+  ---------------------------------------------------------------------}
+
+Procedure SetupInetSocket(Aport : Word);
+
+var
+  Flags,AddrLen : Integer;
+  FInetAddr : TInetSockAddr;
+  FFileName : String;
+  Quit : Boolean;
+     
+begin
+  FSocket:=Socket(AF_INET,SOCK_STREAM,0);
+  If FSocket<0 Then
+    Raise Exception.Create(SErrSocketFailed);
+  Flags:=FCntl(FSocket,F_GETFL);
+  Flags:=Flags or Open_NONBLOCK;
+  FCntl(FSocket,F_SETFL,Flags);
+  FInetAddr.Family := AF_INET;
+  Writeln('Using port : ',APort);
+  FInetAddr.Port := Swap(APort);
+  FInetAddr.Addr := 0;
+  If Not Bind(FSocket,FInetAddr,SizeOf(FInetAddr)) then
+     Raise Exception.CreateFmt(SErrBindFailed,[FFileName]);
+  If Not (Listen(FSocket,5)) then
+    Raise Exception.CreateFmt(SErrListenFailed,[FSocket]);
+end;
+
+Procedure DestroyInetSocket;
+
+Var
+  C : TClient;
+
+begin
+  If Assigned(FClients) then
+    begin
+    With FClients do
+      While Count>0 do
+        begin
+        C:=TClient(Items[Count-1]);
+        FileClose(C.Handle);
+        C.Free;
+        Delete(Count-1);
+        end;
+    FileClose(FSocket);
+    end;
+end;
+
+{ ---------------------------------------------------------------------
+    Communications handling: Public interface
+  ---------------------------------------------------------------------}
+  
+
+Procedure OpenDebugServer;
+
+begin
+  Case DebugConnection of
+    dcUnix : SetupUnixSocket;
+    dcInet : SetupInetSocket(DebugPort);
+  end;  
+  FClients:=TList.Create;  
+  Accepting:=True;
+end;
+
+Procedure CloseDebugServer;
+
+begin
+  Accepting:=False;
+  Case DebugConnection of
+    dcUnix : DestroyUnixSocket;
+    dcInet : DestroyInetSocket;
+  end;  
+  FClients.Free;
+  FClients:=Nil;
+end;
+
+
+{ ---------------------------------------------------------------------
+    Communications handling: Connection handling
+  ---------------------------------------------------------------------}
+  
+Function GetNewConnection : THandle;
+
+Var
+  ClientAddr: TUnixSockAddr;
+  L : Integer;
+
+begin
+  If Accepting then
+    begin
+    L:=SizeOf(ClientAddr);
+    Result:=Accept(FSocket,ClientAddr,L);
+    If (Result<0) Then
+      if (Errno<>SYS_EWOULDBLOCK) then
+        Raise Exception.CreateFmt(SErrAcceptFailed,[FSocket])
+      else
+        Result:=-1
+{$ifdef debug}
+    else
+      Writeln('New connection detected at ',Result)
+{$endif debug}      
+    end  
+  else
+    Result:=-1;
+end;
+
+Function CheckNewConnection : TClient;
+
+Var
+  NC : THandle;
+
+begin
+  NC:=GetNewConnection;
+  If (NC=-1) then
+    Result:=Nil
+  else
+    begin  
+    Result:=TClient.Create;
+    Result.Handle:=NC;
+{$ifdef debug}
+    Writeln('Added new client', nc, ' at : ',FClients.Add(Result));
+{$else}
+    FClients.Add(Result);
+{$endif debug}
+    end;
+end;
+
+Procedure CloseClientHandle(Handle : THandle);
+
+begin
+  ShutDown(Handle,2);
+  FileClose(Handle);
+end;
+
+Procedure CloseConnection(Client : TClient);
+
+Var
+  I : longint;
+  C : TClient;
+  
+begin
+  If Assigned(Client) then
+    begin
+    If Assigned(CloseConnectionCallBack) then
+      CloseConnectionCallBack(Client);
+    If Assigned(CloseObjConnectionCallBack) then
+      CloseObjConnectionCallBack(Client);
+    CloseClientHandle(Client.Handle);
+    FClients.Remove(Client);
+    Client.Free;
+    end;
+end;
+
+{ ---------------------------------------------------------------------
+    Message handling
+  ---------------------------------------------------------------------}
+
+Function MsgToEvent(AHandle: THandle; ALogCode : Integer; ATimeStamp : TDateTime; AEvent : String) : TDebugEvent;
+
+begin
+  With Result do
+    begin
+    Client:=ClientFromHandle(AHandle);
+    If (Client<>Nil) then
+      begin
+      If (ALogCode=lctIdentify) then
+        Client.Peer:=AEvent;
+      end;
+    LogCode:=ALogCode;  
+    TimeStamp:=ATimeStamp;
+    Event:=AEvent;  
+    end;
+end;
+  
+Procedure LogEvent(Event : TDebugEvent);
+    
+begin
+  if Assigned(DebugLogCallback) then
+    DebugLogCallBack(Event);
+  If Assigned(DebugObjLogCallBack) then
+    DebugObjLogCallBack(Event);  
+end;
+
+Procedure ReadMessageEvent(Handle : THandle; Var Event : TDebugEvent);
+
+Var
+  FDebugMessage : TDebugMessage;
+  msgSize : Integer;
+   
+begin
+  Try
+    With FDebugMessage do
+      begin
+      // Select reports read ready when closed, so check for this.
+      If (FileRead(Handle,msgType,SizeOf(Integer))=0) or (MsgType=-1) then
+        begin
+        event:=MsgToEvent(Handle,lctStop,Now,SClosingConnection);
+        If Assigned(Event.Client) then
+          CloseConnection(Event.Client)
+        else
+          CloseClientHandle(Handle);
+        end
+      else
+        begin
+        FileRead(Handle,msgTimeStamp,sizeof(TDateTime));
+        FileRead(Handle,MsgSize,SizeOf(Integer));
+        SetLength(Msg,MsgSize);
+        FileRead(Handle,Msg[1],MsgSize);
+        Event:=MsgToEvent(Handle,msgType,msgTimeStamp,Msg);
+        end
+      end;
+  except
+    On E : Exception do
+      Event:=MsgToEvent(Handle,lctError,Now,E.Message);
+  end;
+end;
+
+Procedure ReadMessage(Handle : THandle);
+
+Var
+  Event : TDebugEvent;
+  
+begin
+  ReadMessageEvent(Handle,Event);
+  LogEvent(Event);
+end;  
+
+end.
+
+{
+  $Log$
+  Revision 1.1  2003-01-02 14:44:29  michael
+  + Initial implementation
+
+}

utils/debugsvr/msgintf.pp

@@ -0,0 +1,51 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2003 by the Free Pascal development team
+
+    Debugclient/server interface definition.
+    
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+unit msgintf;
+
+interface
+
+Type
+  TDebugConnection = (dcUnix,dcInet);
+
+Const
+  DebugSocket          : String = '/tmp/debugserver';
+  DebugHostName        : String = 'localhost';
+  DebugPort            : Word   = 4321;
+  DebugConnection      : TDebugConnection = dcunix;
+  
+  lctStop        = -1;
+  lctInformation = 0;
+  lctWarning     = 1;
+  lctError       = 2;
+  lctIdentify    = 3;
+
+Type
+  TDebugMessage = Record
+    MsgType : Integer;
+    MsgTimeStamp : TDateTime;
+    Msg : String;
+  end;
+
+implementation
+
+end.
+
+{
+  $Log$
+  Revision 1.1  2003-01-02 14:44:29  michael
+  + Initial implementation
+
+}

utils/debugsvr/speeddebug.pp

@@ -0,0 +1,39 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2003 by the Free Pascal development team
+
+    speed test for debug server.
+    
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+{$mode objfpc}
+{$h+}
+program testdebug;
+
+uses dbugintf,sysutils;
+
+Var
+  i : integer;
+  S : String;
+ 
+begin
+  For I:=1 to 10000 do
+    begin
+    S:=Format('Message no %d',[i]);
+    SendDebugEx(S,TDebugLevel(I mod 3));
+    end;
+end.
+
+{
+  $Log$
+  Revision 1.1  2003-01-02 14:44:29  michael
+  + Initial implementation
+
+}

utils/debugsvr/testdebug.pp

@@ -0,0 +1,37 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2003 by the Free Pascal development team
+
+    Interactive test for debugserver.
+    
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+program testdebug;
+
+uses dbugintf;
+
+Var
+ S : String;
+ 
+begin
+  Repeat
+    Writeln('Enter message to send to debug server (STOP exits): ');
+    Write('> ');
+    Readln(S);
+    SendDebugEx(S,dlError);
+  Until (S='STOP');
+end.
+
+{
+  $Log$
+  Revision 1.1  2003-01-02 14:44:29  michael
+  + Initial implementation
+
+}