diff --git a/.gitattributes b/.gitattributes index 955ce41643..88ead7e5c5 100644 --- a/.gitattributes +++ b/.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 diff --git a/packages/fcl-base/examples/dbugsrv.pp b/packages/fcl-base/examples/dbugsrv.pp deleted file mode 100644 index c54042595b..0000000000 --- a/packages/fcl-base/examples/dbugsrv.pp +++ /dev/null @@ -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. - diff --git a/packages/fcl-process/examples/dbugsrv.pp b/packages/fcl-process/examples/dbugsrv.pp new file mode 100644 index 0000000000..8437528009 --- /dev/null +++ b/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. + diff --git a/packages/fcl-process/src/dbugintf.pp b/packages/fcl-process/src/dbugintf.pp index 34a69a1686..6491a722fb 100644 --- a/packages/fcl-process/src/dbugintf.pp +++ b/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. diff --git a/packages/fcl-process/src/dbugmsg.pp b/packages/fcl-process/src/dbugmsg.pp index 2cb575824a..1cc66fa248 100644 --- a/packages/fcl-process/src/dbugmsg.pp +++ b/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;