|
Hi people, I
have an application daemon when is sending the signal TERM in Unix
platform does not end, I attach the code.
Thank you sorry me english unit du; {$mode objfpc}{$H+} interface uses Classes, SysUtils, FileUtil, LResources, DaemonApp, lNet, IniFiles, process, crt; Type { TTestThread } { TTCPThread } TTCPThread = Class(TThread) procedure OnCn(aSocket: TLSocket); procedure OnRe(aSocket: TLSocket); procedure OnDs(aSocket: TLSocket); procedure cmddatet(aSocket: TLSocket); procedure cmdexit(aSocket: TLSocket); procedure cmdnoop(aSocket: TLSocket); procedure cmdsysname(aSocket: TLSocket); procedure cmdos(aSocket: TLSocket); procedure cmdexecute(pass, command : String; aSocket: TLSocket); procedure parse_proto(data1,data2, data3 : String; aSocket: TLSocket); Private FCon: TLTCP; Fconf : TIniFile; proc : TProcess; quit : Boolean; Public Constructor create(ATerminate : TNotifyEvent); Procedure Execute; override; end; type { Twands } Twands = class(TDaemon) procedure DataModuleContinue(Sender: TCustomDaemon; var OK: Boolean); procedure DataModulePause(Sender: TCustomDaemon; var OK: Boolean); procedure DataModuleStart(Sender: TCustomDaemon; var OK: Boolean); procedure DataModuleStop(Sender: TCustomDaemon; var OK: Boolean); private FThread : TTCPThread; procedure ThreadStopped(Sender: TObject); { private declarations } public { public declarations } end; var wands: Twands; implementation procedure RegisterDaemon; begin RegisterDaemonClass(Twands) end; { Twands } procedure Twands.DataModuleContinue(Sender: TCustomDaemon; var OK: Boolean); begin FThread.Resume; end; procedure Twands.DataModulePause(Sender: TCustomDaemon; var OK: Boolean); begin FThread.Suspend; end; procedure Twands.DataModuleStart(Sender: TCustomDaemon; var OK: Boolean); begin OK:=FThread=Nil; If OK then FThread:=TTCPThread.Create(@ThreadStopped); end; procedure Twands.DataModuleStop(Sender: TCustomDaemon; var OK: Boolean); begin If Assigned(FThread) then begin FThread.Terminate; // Let the thread die silently. If (FThread<>Nil) then FThread.OnTerminate:=Nil; end; OK:=FThread=Nil; end; procedure Twands.ThreadStopped(Sender: TObject); begin FThread:=Nil; end; { TTCPThread } procedure TTCPThread.Execute; var Port: Word; pathini : String; begin {$IFDEF WIN32} pathini:=ExtractFilePath(Application.ExeName)+'\wandsd.ini'; {$ENDIF} {$IFDEF LINUX} pathini:=ExtractFilePath(Application.ExeName)+'/wandsd.ini'; {$ENDIF} FCon:= TLTCP.Create(nil); proc := TProcess.Create(nil); Fconf := TIniFile.Create(pathini); FCon.OnReceive := @OnRe; FCon.OnDisconnect := @OnDs; FCon.OnAccept := @OnCn; FCon.Timeout := 100; FCon.ReuseAddress := True; Port := Fconf.ReadInteger('cfg','port',52000); FCon.Listen(Port); quit:=False; Application.Logger.Info('Listening in port '+inttostr(port)); repeat FCon.Callaction; until quit = True; Application.Logger.Info('End thread'); end; procedure TTCPThread.OnCn(aSocket: TLSocket); begin FCon.SendMessage('WandS Service ready'+#10,aSocket); Application.Logger.Info('connected from '+aSocket.PeerAddress); end; procedure TTCPThread.OnRe(aSocket: TLSocket); var s,str1,str2, str3: string; begin if aSocket.GetMessage(s) > 0 then begin str1 := copy(s,pos('<',s)+1,pos('=',s)-2); str2 := copy(s,pos('=',s)+1,pos('|',s)-pos('=',s)-1); str3 := copy(s,pos('|',s)+1,pos('>',s)-pos('|',s)-1); parse_proto(str1,str2, str3,aSocket); end; end; procedure TTCPThread.OnDs(aSocket: TLSocket); begin Application.Logger.Info('disconnect from '+aSocket.PeerAddress); end; procedure TTCPThread.cmddatet(aSocket: TLSocket); begin FCon.SendMessage('<datetime='+DateTimeToStr(Now)+'>'+#10,aSocket) end; procedure TTCPThread.cmdexit(aSocket: TLSocket); begin FCon.SendMessage('<bye>'+#10,aSocket); aSocket.Disconnect; end; procedure TTCPThread.cmdnoop(aSocket: TLSocket); begin FCon.SendMessage('<noop=ok>'+#10,aSocket); end; procedure TTCPThread.cmdsysname(aSocket: TLSocket); var outp : TStringList; begin outp := TStringList.Create; proc.CommandLine := 'hostname'; proc.Options := [poWaitOnExit,poUsePipes]; proc.Execute; outp.LoadFromStream(proc.Output); FCon.SendMessage('<sysname='+outp.ValueFromIndex[0]+'>'+#10,aSocket); outp.Free; end; procedure TTCPThread.cmdos(aSocket: TLSocket); var outp : TStringList; command, messag : String; begin {$IFDEF WIN32} command:='cmd /C ver'; {$ENDIF} {$IFDEF LINUX} command:='uname -a'; {$ENDIF} outp := TStringList.Create; proc.CommandLine := command; proc.Options := [poWaitOnExit,poUsePipes]; proc.Execute; outp.LoadFromStream(proc.Output); {$IFDEF WIN32} messag:='<os='+outp.ValueFromIndex[1]+'>'; {$ENDIF} {$IFDEF LINUX} messag:='<os='+outp.ValueFromIndex[0]+'>'; {$ENDIF} FCon.SendMessage(messag+#10,aSocket); outp.Free; end; procedure TTCPThread.cmdexecute(pass, command: String; aSocket: TLSocket); var outp : TStringList; begin if Fconf.ReadString('cfg','admin','') = pass then begin outp := TStringList.Create; try proc.CommandLine := command; proc.Options := [poWaitOnExit,poUsePipes]; proc.Execute; outp.LoadFromStream(proc.Output); FCon.SendMessage(outp.Text+#10,aSocket); except FCon.SendMessage('Command faild'+#10,aSocket); end; outp.Free; end else begin FCon.SendMessage('Access denied'+#10,aSocket); aSocket.Disconnect; end end; procedure TTCPThread.parse_proto(data1, data2, data3: String; aSocket: TLSocket); begin if data1 = 'exit' then cmdexit(aSocket); if data1 = 'datetime' then cmddatet(aSocket); if data1 = 'noop' then cmdnoop(aSocket); if data1 = 'sysname' then cmdsysname(aSocket); if data1 = 'execute' then cmdexecute(data2,data3,aSocket); if data1 = 'os' then cmdos(aSocket); end; constructor TTCPThread.create(ATerminate: TNotifyEvent); begin FreeOnTerminate:=False; OnTerminate:=ATerminate; Inherited Create(False); end; initialization {$I du.lrs} RegisterDaemon; end. |
_______________________________________________ Lazarus mailing list [email protected] http://www.lazarus.freepascal.org/mailman/listinfo/lazarus
