* Merging revisions r46369 from trunk:

------------------------------------------------------------------------
    r46369 | michael | 2020-08-12 12:58:24 +0200 (Wed, 12 Aug 2020) | 1 line
    
    * Fix bug #37546, improvement to pass log filename to server
    ------------------------------------------------------------------------

git-svn-id: branches/fixes_3_2@46617 -

.gitattributes

@@ -2918,7 +2918,6 @@ packages/fcl-base/examples/contit.pp svneol=native#text/plain
 packages/fcl-base/examples/crittest.pp svneol=native#text/plain
 packages/fcl-base/examples/csvbom.pp svneol=native#text/plain
 packages/fcl-base/examples/databom.txt svneol=native#text/plain
-packages/fcl-base/examples/dbugsrv.pp svneol=native#text/plain
 packages/fcl-base/examples/debugtest.pp svneol=native#text/plain
 packages/fcl-base/examples/decodeascii85.pp svneol=native#text/plain
 packages/fcl-base/examples/demoio.pp svneol=native#text/plain
@@ -3684,6 +3683,7 @@ packages/fcl-process/Makefile.fpc svneol=native#text/plain
 packages/fcl-process/Makefile.fpc.fpcmake svneol=native#text/plain
 packages/fcl-process/examples/checkipcserver.lpi svneol=native#text/plain
 packages/fcl-process/examples/checkipcserver.lpr svneol=native#text/plain
+packages/fcl-process/examples/dbugsrv.pp svneol=native#text/plain
 packages/fcl-process/examples/demoproject.ico -text
 packages/fcl-process/examples/demoproject.lpi svneol=native#text/plain
 packages/fcl-process/examples/demoproject.pp svneol=native#text/plain

packages/fcl-base/examples/dbugsrv.pp

@@ -1,39 +0,0 @@
-program dbugsrv;
-
-{$MODE OBJFPC}
-{$H+}
-{$APPTYPE CONSOLE}
-
-uses
-  classes,SysUtils,simpleipc,dbugmsg;
-
-Var
-  Srv : TSimpleIPCServer;
-  S : String;
-  Msg : TDebugMessage;
-  
-begin
-  Srv:=TSimpleIPCServer.Create(Nil);
-  Try
-    Srv.ServerID:=DebugServerID;
-    Srv.Global:=True;
-    Srv.Active:=True;
-    Srv.StartServer;
-    Writeln('Server started. Listening for debug messages');
-    Repeat
-      If Srv.PeekMessage(1,True) then
-        begin
-        Srv.MsgData.Seek(0,soFrombeginning);
-        ReadDebugMessageFromStream(Srv.MsgData,MSg);
-        Write(FormatDateTime('hh:nn:ss.zzz',Msg.MsgTimeStamp),': ');
-        Write(DebugMessageName(MSg.MsgType):12,' ');
-        Writeln(Msg.Msg);
-        end
-      else
-        Sleep(10);
-    Until False;
-  Finally
-    Srv.Free;
-  end;
-end.
-

packages/fcl-process/examples/dbugsrv.pp

@@ -0,0 +1,142 @@
+{
+  Make sure to set your project's options with, CompilerOptions --> Target "-o" -->Filename Value="fpcdebugserver",
+  i.e. the executable name must be the same as the client's const named dbugmsg.DebugServerID.
+}
+
+program dbugsrv;
+
+{$MODE OBJFPC}
+{$H+}
+{$APPTYPE CONSOLE}
+
+
+uses
+  classes,SysUtils,simpleipc,dbugmsg,strutils;
+
+
+Type
+
+  { THelperToWrite }
+
+  THelperToWrite = class
+    private
+      Class var StrLogFilename: string;
+      Class procedure WriteLnAllParams;
+      Class procedure InitParamsDependencies;
+      { methods which override standard Write and WriteLn of the console output }
+      Class procedure DoWrite(const aBuffer: string);
+      Class procedure DoWrite(var aBuffer: string; const aMinimumFieldWidthIndent: integer); overload;
+      Class procedure DoWriteLn(const aBuffer: string);
+      { methods which write in a log file, too }
+      Class procedure WriteNowThisLineInLog(aBuffer: string);
+      Class procedure WriteLnNowThisLineInLog(aBuffer: string);
+      Class function ReplaceSpecialCharsInLog(const aBuffer: string): string;
+    public
+    end;
+
+
+Var
+  Srv : TSimpleIPCServer;
+  Msg : TDebugMessage;
+  StrBuffer : string = '';
+  ObjFileStream : TFileStream = Nil;
+  
+
+class procedure THelperToWrite.WriteLnAllParams;
+Var
+  iNumParam: integer;
+  sBuffer: string;
+begin
+  sBuffer := 'ParamCount='+IntToStr(ParamCount)+LineEnding;
+  for iNumParam := 0 to ParamCount do
+    sBuffer := IfThen(iNumParam<>ParamCount, sBuffer+'ParamStr('+IntToStr(iNumParam)+') = "'+ParamStr(iNumParam)+'"'+LineEnding, sBuffer+'ParamStr('+IntToStr(iNumParam)+') = "'+ParamStr(iNumParam)+'"');
+  THelperToWrite.DoWriteLn(sBuffer);
+end;
+
+class procedure THelperToWrite.InitParamsDependencies;
+begin
+  If (ParamCount<>0) then
+    if ParamStr(1)<>'' then begin {ord. params: 1st is a log filename}
+      THelperToWrite.StrLogFilename:= ParamStr(1);
+      ObjFileStream:= TFileStream.Create(THelperToWrite.StrLogFilename, fmCreate or fmOpenWrite or fmShareDenyWrite);
+      ObjFileStream.Position:= 0;
+    end;
+end;
+
+class procedure THelperToWrite.DoWrite(const aBuffer: string);
+begin
+  Write(aBuffer);
+  if Assigned(ObjFileStream) then THelperToWrite.WriteNowThisLineInLog(StrBuffer);
+end;
+
+class procedure THelperToWrite.DoWrite(var aBuffer: string; const aMinimumFieldWidthIndent: integer);
+begin
+  Write(aBuffer:aMinimumFieldWidthIndent,' ');
+  if Assigned(ObjFileStream) then THelperToWrite.WriteNowThisLineInLog(StrBuffer);
+end;
+
+class procedure THelperToWrite.DoWriteLn(const aBuffer: string);
+begin
+  WriteLn(aBuffer);
+  if Assigned(ObjFileStream) then THelperToWrite.WriteLnNowThisLineInLog(aBuffer+LineEnding)
+end;
+
+class procedure THelperToWrite.WriteNowThisLineInLog(aBuffer: string);
+var
+  sBuffer: string;
+begin
+  sBuffer:= THelperToWrite.ReplaceSpecialCharsInLog(aBuffer);
+  ObjFileStream.Write(sBuffer[1],length(sBuffer));
+end;
+
+class procedure THelperToWrite.WriteLnNowThisLineInLog(aBuffer: string);
+var
+  sBuffer: string;
+begin
+  aBuffer:= ' '{sep. each field of the msg-record}+aBuffer+LineEnding;
+  sBuffer:= THelperToWrite.ReplaceSpecialCharsInLog(aBuffer);
+  ObjFileStream.Write(sBuffer[1],length(sBuffer));
+end;
+
+class function THelperToWrite.ReplaceSpecialCharsInLog(const aBuffer: string): string;
+begin
+  Result := StringsReplace(aBuffer, [LineEnding+LineEnding], [LineEnding], [rfReplaceAll]);
+end;
+
+ResourceString
+  SWelcomeOnSrv = 'IPC server started. Listening for debug messages:';
+
+
+begin
+  Srv:=TSimpleIPCServer.Create(Nil);
+  Try
+    Srv.ServerID:=DebugServerID;
+    Srv.Global:=True;
+    Srv.Active:=True;
+    Srv.StartServer;
+    THelperToWrite.InitParamsDependencies;
+    THelperToWrite.WriteLnAllParams;
+    StrBuffer:=SWelcomeOnSrv;
+    THelperToWrite.DoWriteLn(StrBuffer);
+    Repeat
+      If Srv.PeekMessage(1,True) then
+        begin
+        Srv.MsgData.Seek(0,soFrombeginning);
+        ReadDebugMessageFromStream(Srv.MsgData,MSg);
+        StrBuffer:=FormatDateTime('hh:nn:ss.zzz',Msg.MsgTimeStamp)+': ';
+        THelperToWrite.DoWrite(StrBuffer);
+        StrBuffer:=DebugMessageName(MSg.MsgType);
+        THelperToWrite.DoWrite(StrBuffer,12);
+        StrBuffer:=Msg.Msg;
+        THelperToWrite.DoWriteLn(StrBuffer);
+        end
+      else
+        Sleep(10);
+    Until False;
+  Finally
+    if Assigned(ObjFileStream) then
+       ObjFileStream.Free;
+    Srv.Free;
+  end;
+end.
+

packages/fcl-process/src/dbugintf.pp

@@ -19,8 +19,11 @@ unit dbugintf;
 
 interface
 
+uses dbugmsg;
+
 Type
   TDebugLevel = (dlInformation,dlWarning,dlError);
+  TErrorLevel = Array[TDebugLevel] of integer;
 
 procedure SendBoolean(const Identifier: string; const Value: Boolean);
 procedure SendDateTime(const Identifier: string; const Value: TDateTime);
@@ -39,34 +42,33 @@ function GetDebuggingEnabled : Boolean;
 
 { low-level routines }
 
-Function  StartDebugServer : integer;
+Function StartDebugServer(const aLogFilename : String = '') : integer;
 Function InitDebugClient : Boolean;
-Function InitDebugClient(const ShowOrNotPID: Boolean) : Boolean; overload;
+function InitDebugClient(const ShowPID: Boolean; const ServerLogFilename: String = ''): Boolean;
+procedure FreeDebugClient;
 
-Const
-  SendError       : String = '';
-  DefaultDebugServer = 'debugserver';
- 
 ResourceString
-  SProcessID = 'Process %s (PID=%d)';
+  SProcessID = '%d Process %s (PID=%d)';
   SEntering = '> Entering ';
   SExiting  = '< Exiting ';
   SSeparator = '>-=-=-=-=-=-=-=-=-=-=-=-=-=-=-<';
   SServerStartFailed = 'Failed to start debugserver. (%s)';
 
 Var
-  DebugServerExe : String = DefaultDebugServer;
+  DebugServerExe     : String = ''; { We can override this global var. in our compiled IPC client, with DefaultDebugServer a.k.a. dbugmsg.DebugServerID, or something else  }
+  DefaultDebugServer : String = DebugServerID ; { A "last ressort" simplier compiled IPC server's name, called in command line by your client a.k.a. the compiler's target file "-o" }
+  SendError          : String = '';
 
 implementation
 
 Uses 
-  SysUtils, classes,dbugmsg, process, simpleipc;
+  SysUtils, classes, process, simpleipc, strutils;
 
 Const
   DmtInformation = lctInformation;
   DmtWarning     = lctWarning;
   DmtError       = lctError;
-  ErrorLevel     : Array[TDebugLevel] of integer
+  ErrorLevel     : TErrorLevel
                  = (dmtInformation,dmtWarning,dmtError);
   IndentChars    = 2;
   
@@ -224,21 +226,23 @@ begin
   Result := not DebugDisabled;
 end;
 
-function StartDebugServer : Integer;
+function StartDebugServer(Const aLogFileName : string = '') : Integer;
 
 Var
   Cmd : string;
 
 begin
-  Cmd:=DebugServerExe;
+  Cmd := DebugServerExe;
   if Cmd='' then
-    Cmd:=DefaultDebugServer;
+    Cmd := DefaultDebugServer;
   With TProcess.Create(Nil) do
     begin
     Try
-      CommandLine:=Cmd;
+      Executable := Cmd;
+      If aLogFileName<>'' Then
+        Parameters.Add(aLogFileName);
       Execute;
-      Result:=ProcessID;
+      Result := ProcessID;
     Except On E: Exception do
       begin
       SendError := Format(SServerStartFailed,[E.Message]);
@@ -261,7 +265,7 @@ begin
       begin
       Msg.MsgType:=lctStop;
       Msg.MsgTimeStamp:=Now;
-      Msg.Msg:=Format(SProcessID,[ApplicationName, GetProcessID]);
+      Msg.Msg:=Format(SProcessID,[GetProcessID, ApplicationName, GetProcessID]);
       WriteMessage(Msg);
       end;
     if assigned(MsgBuffer) then FreeAndNil(MsgBuffer);
@@ -272,17 +276,25 @@ end;
 
 Function InitDebugClient : Boolean;
 
+begin
+  InitDebugClient(False,'');
+end;
+
+
+function InitDebugClient(const ShowPID: Boolean; const ServerLogFilename: String = ''): Boolean;
+
 Var
   msg : TDebugMessage;
   I : Integer;
 
 begin
   Result := False;
+  AlwaysDisplayPID:= ShowPID;
   DebugClient:=TSimpleIPCClient.Create(Nil);
   DebugClient.ServerID:=DebugServerID;
   If not DebugClient.ServerRunning then
     begin
-    ServerID:=StartDebugServer;
+    ServerID:=StartDebugServer(ServerLogFileName);
     if ServerID = 0 then
       begin
       DebugDisabled := True;
@@ -308,17 +320,11 @@ begin
   MsgBuffer:=TMemoryStream.Create;
   Msg.MsgType:=lctIdentify;
   Msg.MsgTimeStamp:=Now;
-  Msg.Msg:=Format(SProcessID,[ApplicationName, GetProcessID]);
+  Msg.Msg:=Format(SProcessID,[GetProcessID, ApplicationName, GetProcessID]);
   WriteMessage(Msg);
   Result := True;
 end;
 
-function InitDebugClient(const ShowOrNotPID: Boolean): Boolean;
-begin
-  AlwaysDisplayPID:= ShowOrNotPID;
-  Result:= InitDebugClient;
-end;
-
 Finalization
   FreeDebugClient;
 end.

packages/fcl-process/src/dbugmsg.pp

@@ -22,7 +22,7 @@ interface
 uses Classes;
 
 Const
-  DebugServerID  : String = 'fpcdebugserver';
+  DebugServerID = 'fpcdebugserver'; { compiled IPC server's IDentifiant-name. Should be the same as the compiled IPC client dbugintf.DefaultDebugServer }
 
   lctStop        = -1;
   lctInformation = 0;