program svnsrv; uses Windows, Messages, Registry, SysUtils, NTService, Magsubs4, Magsubs1, MagTaskWins, ShellAPI ; {$R *.RES} // this program is a service starter that runs Svnserver.exe on server startup, so that // remote users can access the ICS SVN repository svn.overbyte.be with SVN clients. // it must be run once as svnsrv.exe -install to install 'Subversion Server Service' // command line for magpub5 public Windows 2018 server // c:\csvn\bin\svnserve.exe' ' -d -r "d:\svnrepos" --listen-port "3690" --listen-host "217.146.102.149' ; // 20 Jan 2020 - 1.2 - baseline type // Derive a new class from the NT service class TNTTestService = class (TNTService) protected // Override the ;Execute' method. function Execute : Integer; override; function ServiceStop: Boolean ; override; function PostRegisterInitialize: Boolean; override ; // service start procedure UserFunction (Code: integer); override ; end; var MainService: TNTTestService; // LogDiags: boolean ; VhActHandle: THandle ; ProcessId: THandle ; const ProgVersion = 'Magenta Systems Release 1.2 - 20th Januarry 2020' ; ProgServName = 'Subversion Server Service' ; ProgDispName = 'Subversion Server Service' ; // ============================================================================================== // run a program and optionally return immediately with all process information function StartExe2 (const aAppName, aCmdLine, aWorkDir: String; ShowState: Word): TProcessInformation ; var StartupInfo : TStartupInfo; ProcInfo : TProcessInformation; begin {setup the startup information for the application } FillChar (StartupInfo, SizeOf (TStartupInfo), 0); FillChar (Result, SizeOf (Result), 0); with StartupInfo do begin cb := SizeOf (TStartupInfo); dwFlags := STARTF_FORCEONFEEDBACK ; if ShowState <> 0 then begin dwFlags := dwFlags OR STARTF_USESHOWWINDOW ; wShowWindow := ShowState ; // SW_SHOWNORMAL, SW_SHOWMINIMIZED or SW_HIDE end ; end ; if CreateProcess (PChar(aAppName), PChar(aCmdLine), nil, nil, False, NORMAL_PRIORITY_CLASS, nil, PChar(aWorkDir), StartupInfo, ProcInfo) then Result := ProcInfo ; end; // ============================================================================================== // borrowed from RX function fileShellOpen2(const FileName, Params, StartDir: string; InitialState: integer): THandle; var Info: TShellExecuteInfo; // ExitCode: DWORD; begin result := 0 ; FillChar(Info, SizeOf(Info), 0); Info.cbSize := SizeOf(TShellExecuteInfo); with Info do begin fMask := SEE_MASK_NOCLOSEPROCESS; // Wnd := Application.Handle; lpFile := PChar(FileName); lpParameters := PChar(Params); lpDirectory := PChar(StartDir); nShow := InitialState ; end; if ShellExecuteEx(@Info) then begin result := Info.hProcess ; end ; end; // ============================================================================================== // ============================================================================================== function TNTTestService.PostRegisterInitialize: Boolean; var basedir, fname, cmdline: string ; ProcessInfo : TProcessInformation; begin result := false ; // start vehicle activity server basedir := ExtractFilePath (ParamStr(0)) ; ProcessId := 0 ; VhActHandle := 0 ; fname := 'c:\csvn\bin\svnserve.exe' ; cmdline := ' -d -r "d:\svnrepos" --listen-port "3690" --listen-host "217.146.102.149' ; ProcessInfo := StartExe2 (fname, cmdline, basedir, SW_SHOWNORMAL) ; VhActHandle := ProcessInfo.hProcess ; if VhActHandle = 0 then begin LogMessage ('SvnServer Failed to Failed to Start: ' + fname + space + cmdline, EVENTLOG_ERROR_TYPE, 0, 0) ; // event log exit ; end ; (* VhActHandle := fileShellOpen2 (fname, cmdline, basedir, SW_NORMAL) ; if VhActHandle = 0 then begin LogMessage ('SvnServer Failed to Failed to Start: ' + fname + space + cmdline, EVENTLOG_ERROR_TYPE, 0, 0) ; // event log exit ; end ; *) LogMessage ('SvnServer Started OK ' + fname + space + IntToStr (ProcessId), EVENTLOG_INFORMATION_TYPE, 0, 0) ; // event log result := true ; end; function TNTTestService.ServiceStop: Boolean ; var exitcode: integer ; begin result := true ; try if ProcessId <> 0 then begin exitcode := 0 ; TermPID (ProcessId, exitcode) ; if ExitCode <> Still_Active then begin ProcessId := 0 ; LogMessage ('SvnServer Stopped OK', EVENTLOG_INFORMATION_TYPE, 0, 0) ; // event log end else begin result := false ; LogMessage ('SvnServer Failed to Stop', EVENTLOG_INFORMATION_TYPE, 0, 0) ; // event log end ; exit ; end ; // try the hard way, no clear-ups if VhActHandle <> 0 then begin if TerminateProcess (VhActHandle, 0) then begin VhActHandle := 0 ; LogMessage ('SvnServer Stopped OK', EVENTLOG_INFORMATION_TYPE, 0, 0) ; // event log end else begin result := false ; LogMessage ('SvnServer Failed to Stop', EVENTLOG_INFORMATION_TYPE, 0, 0) ; // event log end ; end ; except end ; end; function TNTTestService.Execute : Integer; var lpExitCode: longword ; begin result := 0; if ProcessId <> 0 then begin while not Terminated do begin if NOT CheckExePID (ProcessId) then begin LogMessage ('SvnServer Terminated', EVENTLOG_INFORMATION_TYPE, 0, 0) ; // event log exit ; end ; Sleep (5000) ; // very important to stop heavy CPU usage end; exit ; end ; if VhActHandle <> 0 then begin while not Terminated do begin GetExitCodeProcess (VhActHandle, lpExitCode) ; if lpExitCode <> Still_Active then begin LogMessage ('SvnServer Terminated', EVENTLOG_INFORMATION_TYPE, 0, 0) ; // event log exit ; end ; Sleep (5000) ; // very important to stop heavy CPU usage end; exit ; end ; LogMessage ('SvnServer Handles Not Found', EVENTLOG_ERROR_TYPE, 0, 0) ; // event log end; procedure TNTTestService.UserFunction (Code: integer); begin // end; begin MainService := TNTTestService.Create (ProgServName, ProgDispName); try MainService.AllowPause := false ; MainService.AllowStop := true ; // MainService.Logging := true ; MainService.Run; except MainService.LogMessage ('SvnServer Exception: ' + GetExceptMess (ExceptObject), EVENTLOG_ERROR_TYPE, 0, 0) ; // event log end ; MainService.Free end.