0a1 > 3c4 < { CodeGear Delphi Visual Component Library } --- > { Delphi Visual Component Library } 5c6 < { Copyright (c) 1995-2007 CodeGear } --- > { Copyright(c) 1995-2013 Embarcadero Technologies, Inc. } 7a9,61 > { } > { Portions created by Arno Garrels } > { are Copyright (c) 2006-2013 Arno Garrels. } > { } > { ******* You may NOT distribute this unit! ******* } > { ******* Distribute the diff file only! ******* } > { The diff file is available in the download package } > { URL: http://www.duodata.de/misc/delphi/DDService.zip } > { } > { Enhanced NT Service Framework: } > { - Win 2000 FailureOptions and FailureActions, } > { Service Description. } > { HandlerEx extended service controls: } > { ParamChange, NetBindChange. } > { - Optional console control handler } > { Optional device events as well as power events. } > { Assigning one of those events will create a window } > { in the context of the service thread. } > { This window is also created when option } > { eoSynchronizeConsoleEvents is set. } > { - Win XP SessionChange service control } > { - Win Vista PreShutdown service control and } > { NonCrashFailures, Service SID Info, Required } > { Privileges and StartType AutoDelayed. } > { } > { Revision History: } > { 06 March 07 Removed calls to Classes.(De)AllocateHwnd } > { since they are not thread-safe. Made WndProc virtual. } > { 08 Sept 07 New event OnRunException. } > { 17 Oct, 08 New property ServiceName. Fixed a major } > { (CodeGear) bug in TDDService.ReportStatus. } > { As a result it is now possible to delay Vista system } > { shutdown in event OnPreshutdown. Also random } > { ERangeErrors in function ReportStatus are now gone. } > { Delphi 2009 compatibility added. } > { - V1.4 03 Nov, 2008 - } > { The image path is now enclosed in double quotes if it } > { includes spaces. Added const WM_USER_DDSERVICE that } > { should be used as a base to create custom message IDs } > { for custom messages to be sent to the service window. } > { } > { - V1.5 August 2011 - } > { Added support for Delphi XE2 } > { Added support for C++ Builder 2006 - XE2 } > { } > { - V1.6 August 2012 - } > { Added support for Delphi and C++ Builder XE3 } > { - V1.7 April 2013 - } > { Added support for Delphi and C++ Builder XE4 } > { } > {*******************************************************} > > unit DDSvcMgr; 9c63,73 < unit SvcMgr; --- > {$I DDCompilers.inc} > > {$IFDEF COMPILER6_UP} > {$WARN SYMBOL_PLATFORM OFF} > {$WARN SYMBOL_LIBRARY OFF} > {$IFDEF COMPILER14_UP} > {$WARN SYMBOL_DEPRECATED OFF} // TThread.Resume Suspend > {$ENDIF} > {$ENDIF} > > {$DEFINE COMPATIBILITY} 14a79,83 > {$IFDEF VER_UNKNOWN} > {$MESSAGE WARN 'You are compiling DDService with an unknown compiler version.'} > {$ENDIF} > > {$IFDEF COMPILER16_UP} 16c85,103 < Windows, Messages, SysUtils, Classes, WinSvc; --- > Winapi.Windows, Winapi.Messages, Winapi.WinSvc, System.SysUtils, > System.Classes, DDWindows, DDWinSvc, > {$IFDEF COMPILER17_UP} > System.UITypes, > {$ENDIF} > DDSvcConsts; > {$ELSE} > uses > Windows, Messages, WinSvc, SysUtils, Classes, > {$IFNDEF COMPILER6_UP} > Forms, > {$ENDIF} > DDWindows, DDWinSvc, DDSvcConsts; > {$ENDIF} > > const > CUSTOMCONTROL_LOW = 128; > CUSTOMCONTROL_HIGH = 255; > DEFAULT_PRESHUTDOWN_TIMEOUT = 180000; 21a109,113 > {$IFNDEF COMPATIBILITY} > TEventLogType = (etError, etWarning, etInformation, etAuditSuccess, > etAuditFailure); > {$ENDIF} > 25c117 < FEventLog: Integer; --- > FEventLog: THandle; 29c121,126 < procedure LogMessage(Message: String; EventType: DWord = 1; --- > procedure LogMessage(Msg: String; > {$IFNDEF COMPATIBILITY} > EventType: TEventLogType = etError; > {$ELSE} > EventType: DWord = EVENTLOG_ERROR_TYPE; > {$ENDIF} 64c161,164 < CM_SERVICE_CONTROL_CODE = WM_USER + 1; --- > CM_SERVICE_CONTROL_CODE = WM_USER + 1; // Posted to service thread > //CM_SERVICE_CONTROL_SESSIONCHANGE = WM_USER + 2; // Moved to implementation section > //CM_SERVICE_CONSOLE_CTRL = WM_USER + 3; // Moved to implementation section > WM_USER_DDSERVICE = WM_USER + 4; // First available custom ID, see implementation 68c168 < TService = class; --- > TDDService = class; 72c172 < FService: TService; --- > FService: TDDService; 74a175 > 76c177 < constructor Create(Service: TService); --- > constructor Create(Service: TDDService); 80c181 < { TService } --- > { TFailureAction } 82c183 < TServiceController = procedure(CtrlCode: DWord); stdcall; --- > TFailureActionType = (faNone, faRestart, faReboot, faRunCommand); 84c185,198 < TServiceType = (stWin32, stDevice, stFileSystem); --- > TFailureAction = class(TCollectionItem) > private > FActionType: TFailureActionType; > FDelay: Integer; // milliseconds > procedure SetDelay(Value: Integer); > procedure SetActionType(Value: TFailureActionType); > protected > function GetDisplayName: String; override; > public > procedure Assign(Source: TPersistent); override; > published > property ActionType: TFailureActionType read FActionType write SetActionType; > property Delay: Integer read FDelay write SetDelay; > end; 86,87c200 < TCurrentStatus = (csStopped, csStartPending, csStopPending, csRunning, < csContinuePending, csPausePending, csPaused); --- > { TFailureActions } 89c202,212 < TErrorSeverity = (esIgnore, esNormal, esSevere, esCritical); --- > TFailureActions = class(TCollection) > private > FOwner: TPersistent; > protected > function GetItems(Index: Integer): TFailureAction; > public > function GetOwner: TPersistent; override; > function Add: TFailureAction; > constructor Create(AOwner: TPersistent); > property Items[Index: Integer]: TFailureAction read GetItems; default; > end; 91c214 < TStartType = (stBoot, stSystem, stAuto, stManual, stDisabled); --- > { TFailureOptions } 93,97c216,264 < TServiceEvent = procedure(Sender: TService) of object; < TContinueEvent = procedure(Sender: TService; var Continued: Boolean) of object; < TPauseEvent = procedure(Sender: TService; var Paused: Boolean) of object; < TStartEvent = procedure(Sender: TService; var Started: Boolean) of object; < TStopEvent = procedure(Sender: TService; var Stopped: Boolean) of object; --- > TFailureOptions = class(TPersistent) > private > FResetPeriod: Integer; // milliseconds > FRebootMessage: String; > FCommand: String; > FNonCrashFailures: Boolean; // Vista only > public > procedure Assign(Source: TPersistent); override; > constructor Create; > published > property ResetPeriod: Integer read FResetPeriod write FResetPeriod default -1; > property RebootMessage: String read FRebootMessage write FRebootMessage; > property Command: String read FCommand write FCommand; > property NonCrashFailures: Boolean read FNonCrashFailures write FNonCrashFailures default False; > end; > > { TDDService } > > {$IFDEF WIN64} > TDDIntPtr = type Int64; > {$ELSE} > TDDIntPtr = type Integer; > {$ENDIF} > > TExOptions = set of (eoForceServiceThreadWindow, eoSynchronizeConsoleEvents, > eoSuspendServiceThreadOnPause); > TServiceSidType = (stNone, stUnrestricted, stRestricted); > TAllowedExControls = set of (alParamChange, alNetBindChange, alSessionChange, > alPreShutdown); > TServiceControllerEx = function(CtrlCode, EventType: DWord; > EventData, Context: Pointer): DWord; stdcall; > TServiceConsoleCtrlHandler = function(Ctrl: DWord): Bool; stdcall; > TServiceController = procedure(CtrlCode: DWord); stdcall; > TServiceType = (stWin32, stDevice, stFileSystem); > TCurrentStatus = (csStopped, csStartPending, csStopPending, csRunning, > csContinuePending, csPausePending, csPaused); > TErrorSeverity = (esIgnore, esNormal, esSevere, esCritical); > TStartType = (stBoot, stSystem, stAuto, stManual, stDisabled, stAutoDelayed); > TServiceEvent = procedure(Sender: TDDService) of object; > TContinueEvent = procedure(Sender: TDDService; var Continued: Boolean) of object; > TPauseEvent = procedure(Sender: TDDService; var Paused: Boolean) of object; > TStartEvent = procedure(Sender: TDDService; var Started: Boolean) of object; > TStopEvent = procedure(Sender: TDDService; var Stopped: Boolean) of object; > TSessionChangeEvent = procedure (Sender: TDDService; EventType, SessionID: Integer) of object; > TCustomControlEvent = procedure(Sender: TDDService; CtrlCode: Integer) of object; > TConsoleEvent = procedure(Sender: TDDService; CtrlCode: Integer; var Handled: Boolean) of object; > TControlEvent = procedure(Sender: TDDService; EventType: Integer) of object; > TMessageEvent = procedure(Sender: TDDService; EventType: Integer; EventData: TDDIntPtr; var MsgResult: Integer) of object; > TServiceExceptionEvent = procedure(Sender: TObject; E: Exception; var LogDefaultErrMsg, CanAbort: Boolean) of object; 99c266 < TService = class(TDataModule) --- > TDDService = class(TDataModule) 100a268 > FServiceStatus: TServiceStatus; 102a271,273 > FAllowedExControls: TAllowedExControls; > FConsoleHandler: Pointer; > FPreShutdownTimeout: Integer; 103a275 > FDescription: String; 104a277 > FServiceName: String; 107a281,282 > FFailureActions: TFailureActions; > FFailureOptions: TFailureOptions; 108a284 > FImagePath: String; 111a288 > FRequiredPrivileges: TStrings; 113a291 > FExOptions: TExOptions; 114a293 > FServiceSidType: TServiceSidType; 118a298 > FServiceWindow: Hwnd; 124a305 > FTriggerStarted: Boolean; 125a307 > FOnDeviceEvent: TMessageEvent; 126a309,310 > //FOnHardwareProfileChange: TMessageEvent; > FOnNetBindChange: TControlEvent; 127a312 > FOnPowerEvent: TMessageEvent; 128a314,315 > FOnPreShutdown: TServiceEvent; > FOnParamChange: TServiceEvent; 130a318,321 > FOnSessionChange: TSessionChangeEvent; > FOnCustomControl: TCustomControlEvent; > FOnConsoleEvent: TConsoleEvent; > FOnRunException: TServiceExceptionEvent; 131a323,324 > function GetServiceName: String; > procedure SetServiceName(const Value: String); 137,140c330,333 < function GetNTServiceType: Integer; < function GetNTStartType: Integer; < function GetNTErrorSeverity: Integer; < function GetNTControlsAccepted: Integer; --- > function GetNTServiceType: DWORD; > function GetNTStartType: DWORD; > function GetNTErrorSeverity: DWORD; > function GetNTControlsAccepted: DWORD; 143a337 > procedure SetOnConsoleEvent(Value: TConsoleEvent); 145a340,342 > function AreFailureActionsStored: Boolean; > procedure SetFailureOptions(Value: TFailureOptions); > procedure SetFailureActions(Value: TFailureActions); 148a346,358 > procedure SetDescription(const Value: String); > procedure SetOnPreShutDown(Value: TServiceEvent); > procedure SetOnParamChange(Value: TServiceEvent); > procedure SetOnSessionChange(Value: TSessionChangeEvent); > procedure SetRequiredPrivileges(Value: TStrings); > procedure SetOnNetBindChange(Value: TControlEvent); > procedure SetExOptions(Value: TExOptions); > procedure SetOnPowerEvent(Value: TMessageEvent); > procedure SetOnDeviceEvent(Value: TMessageEvent); > procedure CheckCreateServiceThreadWindow; > procedure DestroyServiceThreadWindow; > function AllocateHWnd: HWND; > procedure DeallocateHWnd(WndHandle: HWND); 149a360,362 > {$IFDEF COMPILER16_UP} > procedure Main(Argc: DWord; Argv: PLPWSTR); > {$ELSE} 150a364 > {$ENDIF} 151a366,367 > function ControllerEx(CtrlCode, EventType: DWord; EventData, Context: Pointer): DWord; > function ConsoleCtrlHandler(Ctrl: DWord): LongBool; 153,155c369,371 < function DoStop: Boolean; virtual; < function DoPause: Boolean; virtual; < function DoContinue: Boolean; virtual; --- > function DoStop: Boolean; virtual; > function DoPause: Boolean; virtual; > function DoContinue: Boolean; virtual; 158c374,385 < function DoCustomControl(CtrlCode: DWord): Boolean; virtual; --- > procedure DoCustomControl(CtrlCode: DWord); virtual; > function DoDeviceEvent(EventType: Integer; EventData: TDDIntPtr): Integer; virtual; > //function DoHardwareProfileChange(EventType: Integer): Integer; virtual; > function DoRunException(E: Exception; var CanAbort: Boolean): Boolean; virtual; > procedure DoNetBindChange(EventType: Integer); virtual; > procedure DoSessionChange(EventType, SessionID: Integer); virtual; > function DoPowerEvent(EventType: Integer; EventData: TDDIntPtr): Integer; virtual; > function DoConsoleEvent(CtrlCode: Integer): Boolean; virtual; > procedure DoParamChange; virtual; > procedure DoPreShutdown; virtual; > function ThreadWindowNeeded: Boolean; virtual; > procedure WndProc(var MsgRec: TMessage); virtual; 160c387,388 < constructor CreateNew(AOwner: TComponent; Dummy: Integer); override; --- > constructor Create(AOwner: TComponent); override; > constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override; 162a391,392 > function GetServiceControllerEx: TServiceControllerEx; virtual; abstract; > function GetConsoleCtrlHandler: TServiceConsoleCtrlHandler; virtual; abstract; 164c394 < procedure LogMessage(Message: String; EventType: DWord = 1; --- > procedure LogMessage(Msg: String; {$IFNDEF COMPATIBILITY}EventType: TEventLogType = etError;{$ELSE}EventType: DWord = 1;{$ENDIF} 165a396 > procedure Stop; 166a398 > property ImagePath: String read FImagePath write FImagePath; 171a404,405 > property TriggerStarted: Boolean read FTriggerStarted; > property ServiceWindow: HWND read FServiceWindow; 175a410 > property AllowedExControls: TAllowedExControls read FAllowedExControls write FAllowedExControls default []; 177c412,414 < property DisplayName: String read GetDisplayName write FDisplayName; --- > property DisplayName: String read GetDisplayName write FDisplayName {stored False}; > property ServiceName: String read GetServiceName write SetServiceName {stored False}; > property Description: String read FDescription write SetDescription; 178a416,418 > property ExOptions: TExOptions read FExOptions write SetExOptions default [eoSuspendServiceThreadOnPause]; > property FailureOptions: TFailureOptions read FFailureOptions write SetFailureOptions; > property FailureActions: TFailureActions read FFailureActions write SetFailureActions stored AreFailureActionsStored; 181a422,423 > property PreShutdownTimeout: Integer read FPreShutdownTimeout write FPreShutdownTimeout default DEFAULT_PRESHUTDOWN_TIMEOUT; > property RequiredPrivileges: TStrings read FRequiredPrivileges write SetRequiredPrivileges; 184a427 > property ServiceSidType: TServiceSidType read FServiceSidType write FServiceSidType default stNone; 191a435 > property OnDeviceEvent: TMessageEvent read FOnDeviceEvent write SetOnDeviceEvent; 192a437,438 > property OnNetBindChange: TControlEvent read FOnNetBindChange write SetOnNetBindChange; > property OnParamChange: TServiceEvent read FOnParamChange write SetOnParamChange; 193a440,441 > property OnPowerEvent: TMessageEvent read FOnPowerEvent write SetOnPowerEvent; > property OnRunException: TServiceExceptionEvent read FOnRunException write FOnRunException; 196a445,448 > property OnSessionChange: TSessionChangeEvent read FOnSessionChange write SetOnSessionChange; > property OnCustomControl : TCustomControlEvent read FOnCustomControl write FOnCustomControl; > property OnConsoleEvent: TConsoleEvent read FOnConsoleEvent write SetOnConsoleEvent; > property OnPreShutdown: TServiceEvent read FOnPreShutdown write SetOnPreShutdown; 200a453,454 > TExceptionEvent = procedure(Sender: TObject; E: Exception; var Handled: Boolean) of object; > 206a461 > FOnException: TExceptionEvent; 211a467,469 > {$IFDEF COMPILER16_UP} > procedure DispatchServiceMain(Argc: DWord; Argv: PLPWSTR); > {$ELSE} 212a471 > {$ENDIF} 213a473 > procedure ChangeServiceConfiguration2(Service: TDDService; hService: THandle); {virtual;} 218a479 > property EventLogger: TEventLogger read FEventLogger; 224a486 > property OnException: TExceptionEvent read FOnException write FOnException; 226a489,490 > function IsValidServiceName(const SvcName: string): Boolean; > 231a496 > {$IFDEF COMPILER16_UP} 233c498,603 < Forms, Dialogs, Consts; --- > {$IFDEF COMPILER6_UP} > Vcl.Forms, > {$ENDIF} > Vcl.Dialogs, Vcl.Consts; > {$ELSE} > uses > {$IFDEF COMPILER6_UP} > Forms, > {$ENDIF} > Dialogs, Consts; > {$ENDIF} > > const > CM_SERVICE_CONTROL_SESSIONCHANGE = WM_USER + 2; // Posted to service thread > CM_SERVICE_CONSOLE_CTRL = WM_USER + 3; // Sent to ServiceWindow > ActionTypes: array[TFailureActionType] of SC_ACTION_TYPE = > (SC_ACTION_NONE, SC_ACTION_RESTART, > SC_ACTION_REBOOT, SC_ACTION_RUN_COMMAND); > {$IFNDEF COMPATIBILITY} > EventLogTypes : array[etError..etAuditFailure] of DWord = ( > EVENTLOG_ERROR_TYPE, EVENTLOG_WARNING_TYPE, > EVENTLOG_INFORMATION_TYPE, EVENTLOG_AUDIT_SUCCESS, > EVENTLOG_AUDIT_FAILURE); > {$ENDIF} > WndClassName: PChar = 'ServiceThreadWndClass'; > > var > WndCnt: Integer = 0; > CritSectWndClass: TRtlCriticalSection; > { > function CtrlCodeToStr(Ctrl: DWord): String; > begin > case Ctrl of > SERVICE_CONTROL_STOP : Result := 'SERVICE_CONTROL_STOP'; > SERVICE_CONTROL_PAUSE : Result := 'SERVICE_CONTROL_PAUSE'; > SERVICE_CONTROL_CONTINUE : Result := 'SERVICE_CONTROL_CONTINUE'; > SERVICE_CONTROL_INTERROGATE : Result := 'SERVICE_CONTROL_INTERROGATE'; > SERVICE_CONTROL_SHUTDOWN : Result := 'SERVICE_CONTROL_SHUTDOWN'; > SERVICE_CONTROL_PARAMCHANGE : Result := 'SERVICE_CONTROL_PARAMCHANGE'; > SERVICE_CONTROL_NETBINDADD : Result := 'SERVICE_CONTROL_NETBINDADD'; > SERVICE_CONTROL_NETBINDREMOVE : Result := 'SERVICE_CONTROL_NETBINDREMOVE'; > SERVICE_CONTROL_NETBINDENABLE : Result := 'SERVICE_CONTROL_NETBINDENABLE'; > SERVICE_CONTROL_NETBINDDISABLE : Result := 'SERVICE_CONTROL_NETBINDDISABLE'; > SERVICE_CONTROL_DEVICEEVENT : Result := 'SERVICE_CONTROL_DEVICEEVENT'; > SERVICE_CONTROL_HARDWAREPROFILECHANGE : Result := 'SERVICE_CONTROL_HARDWAREPROFILECHANGE'; > SERVICE_CONTROL_POWEREVENT : Result := 'SERVICE_CONTROL_POWEREVENT'; > SERVICE_CONTROL_SESSIONCHANGE : Result := 'SERVICE_CONTROL_SESSIONCHANGE'; > SERVICE_CONTROL_PRESHUTDOWN : Result := 'SERVICE_CONTROL_PRESHUTDOWN'; > else > Result := 'Unknown_Control'; > end; > end; > } > function IsWin2K: Boolean; {$IFDEF USE_INLINE} inline; {$ENDIF} > begin > Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion >= 5); > end; > > function IsWinXP: Boolean; {$IFDEF USE_INLINE} inline; {$ENDIF} > begin > Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and > (((Win32MajorVersion = 5) and (Win32MinorVersion >= 1)) or > (Win32MajorVersion > 5)); > end; > > function IsWinVista: Boolean; {$IFDEF USE_INLINE} inline; {$ENDIF} > begin > Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion >= 6) > end; > > function IsWin7: Boolean; {$IFDEF USE_INLINE} inline; {$ENDIF} > begin > Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and > (((Win32MajorVersion = 6) and (Win32MinorVersion >= 1)) or > (Win32MajorVersion > 6)); > end; > > function StrToMultiSZ(AStrings: TStrings): String; > var > I, Len: Integer; > P: PChar; > begin > Result := ''; > Len := 0; > for I := 0 to AStrings.Count - 1 do > Inc(Len, Length(AStrings[I]) + 1); // For null-terminator > if Len <> 0 then > begin > Inc(Len); // For final null-terminator; > SetLength(Result, Len); > P := @Result[1]; > for I := 0 to AStrings.Count - 1 do > begin > P := StrECopy(P, PChar(AStrings[I])); > Inc(P); > end; > P^ := #0; > end; > end; > > {$IFNDEF COMPILER6_UP} > procedure RaiseLastOSError; > begin > RaiseLastWin32Error; > end; > {$ENDIF} 238a609 > inherited Create; 245a617 > begin 246a619,620 > FEventLog := 0; > end; 250c624,629 < procedure TEventLogger.LogMessage(Message: String; EventType: DWord; --- > procedure TEventLogger.LogMessage(Msg: String; > {$IFNDEF COMPATIBILITY} > EventType: TEventLogType; > {$ELSE} > EventType: DWord; > {$ENDIF} 253c632 < P: Pointer; --- > PMsg: Pointer; 255c634 < P := PChar(Message); --- > PMsg := PChar(Msg); 258c637,642 < ReportEvent(FEventLog, EventType, Category, ID, nil, 1, 0, @P, nil); --- > {$IFNDEF COMPATIBILITY} > ReportEvent(FEventLog, EventLogTypes[EventType], > Category, ID, nil, 1, 0, @PMsg, nil); > {$ELSE} > ReportEvent(FEventLog, EventType, Category, ID, nil, 1, 0, @PMsg, nil); > {$ENDIF} 295c679,767 < constructor TServiceThread.Create(Service: TService); --- > function ThreadWindowProc(aWnd: HWND; aMsg: UINT; aWParam: WPARAM; > aLParam: LPARAM): LRESULT; stdcall; > var > Obj: TObject; > MsgRec: TMessage; > begin > {$IFDEF WIN64} > Obj := TObject(GetWindowLongPtr(aWnd, 0)); > {$ELSE} > Obj := TObject(GetWindowLong(aWnd, 0)); > {$ENDIF} > if not (Obj is TDDService) then > Result := DefWindowProc(aWnd, aMsg, aWParam, aLParam) > else begin > MsgRec.Msg := aMsg; > MsgRec.WParam := aWParam; > MsgRec.LParam := aLParam; > MsgRec.Result := 0; > TDDService(Obj).WndProc(MsgRec); > Result := MsgRec.Result; > end; > end; > > function TDDService.AllocateHWnd : HWND; > var > WndClass: TWndClass; > Res: Hwnd; > begin > Result := 0; > EnterCriticalSection(CritSectWndClass); > try > if not GetClassInfo(HInstance, WndClassName, WndClass) then > begin > ZeroMemory(@WndClass, SizeOf(TWndClass)); > with WndClass do > begin > lpfnWndProc := @ThreadWindowProc; > cbWndExtra := SizeOf(Pointer); > hInstance := SysInit.HInstance; > lpszClassName := WndClassName; > end; > {$IFDEF COMPILER16_UP} > Res := Winapi.Windows.RegisterClass(WndClass); > {$ELSE} > Res := Windows.RegisterClass(WndClass); > {$ENDIF} > if Res = 0 then > Exit; > end; > Res := CreateWindowEx(WS_EX_TOOLWINDOW, WndClassName, > '', WS_POPUP, 0, 0, 0, 0, 0, 0, HInstance, nil); > if Res = 0 then > Exit; > {$IFDEF WIN64} > SetWindowLongPtr(Res, 0, INT_PTR(Self)); > {$ELSE} > SetWindowLong(Res, 0, Integer(Self)); > {$ENDIF} > Inc(WndCnt); > Result := Res; > finally > LeaveCriticalSection(CritSectWndClass); > end; > end; > > procedure TDDService.DeallocateHWnd(WndHandle: HWND); > begin > EnterCriticalSection(CritSectWndClass); > try > if WndHandle = 0 then Exit; > {$IFDEF WIN64} > SetWindowLongPtr(WndHandle, 0, 0); > {$ELSE} > SetWindowLong(WndHandle, 0, 0); > {$ENDIF} > DestroyWindow(WndHandle); > Dec(WndCnt); > if WndCnt <= 0 then > {$IFDEF COMPILER16_UP} > Winapi.Windows.UnregisterClass(WndClassName, HInstance); > {$ELSE} > Windows.UnregisterClass(WndClassName, HInstance); > {$ENDIF} > finally > LeaveCriticalSection(CritSectWndClass); > end; > end; > > constructor TServiceThread.Create(Service: TDDService); 315,316c787,788 < if Assigned(FService.OnStart) then FService.OnStart(FService, Started); < if not Started then Exit; --- > if FService.ThreadWindowNeeded then > FService.CheckCreateServiceThreadWindow; 318,326c790,809 < FService.Status := csRunning; < if Assigned(FService.OnExecute) then < FService.OnExecute(FService) < else < ProcessRequests(True); < ProcessRequests(False); < except < on E: Exception do < FService.LogMessage(Format(SServiceFailed,[SExecute, E.Message])); --- > FService.OnConsoleEvent := FService.FOnConsoleEvent; > try > if Assigned(FService.OnStart) then FService.OnStart(FService, Started); > if not Started then Exit; > try > FService.Status := csRunning; > if Assigned(FService.OnExecute) then > FService.OnExecute(FService) > else > ProcessRequests(True); > ProcessRequests(False); > except > on E: Exception do > FService.LogMessage(Format(SServiceFailed,[SExecute, E.Message])); > end; > finally > FService.OnConsoleEvent := nil; > end; > finally > FService.DestroyServiceThreadWindow; 334d816 < procedure TServiceThread.ProcessRequests(WaitForMessage: Boolean); 336,337c818,823 < ActionStr: array[1..5] of String = (SStop, SPause, SContinue, SInterrogate, < SShutdown); --- > ActionStr: array[1..15] of String = (SStop, SPause, SContinue, SInterrogate, > SShutdown, SParamChange, SNetBindAdd, SNetBindRemove, SNetBindEnable, > SNetBindDisable, SDeviceEvent, SHardwareProfileChange, SPowerEvent, > SSessionChange, SPreShutdown); > > procedure TServiceThread.ProcessRequests(WaitForMessage: Boolean); 339c825 < msg: TMsg; --- > msg: tagMSG; 342a829 > CanAbort: Boolean; 351a839 > 364a853,858 > SERVICE_CONTROL_PARAMCHANGE: FService.DoParamChange; > SERVICE_CONTROL_NETBINDADD, > SERVICE_CONTROL_NETBINDREMOVE, > SERVICE_CONTROL_NETBINDENABLE, > SERVICE_CONTROL_NETBINDDISABLE: FService.DoNetBindChange(msg.wParam); > SERVICE_CONTROL_PRESHUTDOWN: FService.DoPreShutDown; 366c860,861 < ActionOK := FService.DoCustomControl(msg.wParam); --- > {user-defined control code = Range 128 to 255 } > FService.DoCustomControl(msg.wParam); 375,379c870,879 < if msg.wParam in [1..5] then < ErrorMsg := Format(SServiceFailed, [ActionStr[msg.wParam], E.Message]) < else < ErrorMsg := Format(SCustomError,[msg.wParam, E.Message]); < FService.LogMessage(ErrorMsg); --- > if FService.DoRunException(E, CanAbort) then > begin > if msg.wParam in [1..15] then > ErrorMsg := Format(SServiceFailed, [ActionStr[msg.wParam], E.Message]) > else > ErrorMsg := Format(SCustomError,[msg.wParam, E.Message]); > FService.LogMessage(ErrorMsg); > end; > if CanAbort then > Abort; 382c882,899 < end else --- > end > else if msg.message = CM_SERVICE_CONTROL_SESSIONCHANGE then > begin > try > FService.DoSessionChange(Msg.wParam, Msg.lParam); > except > on E: Exception do > begin > if FService.DoRunException(E, CanAbort) then > FService.LogMessage(Format(SServiceFailed, > [ActionStr[SERVICE_CONTROL_SESSIONCHANGE], E.Message])); > if CanAbort then > Abort; > end; > end; > end > else begin > TranslateMessage(msg); 384c901,904 < end else --- > end; > end > else begin > TranslateMessage(msg); 385a906,934 > end; > end; > end; > > procedure TDDService.WndProc(var MsgRec: TMessage); > var > CanAbort: Boolean; > begin > try > case MsgRec.Msg of > CM_SERVICE_CONSOLE_CTRL: > MsgRec.Result := Ord(DoConsoleEvent(MsgRec.WParam)); > WM_POWERBROADCAST: > MsgRec.Result := DoPowerEvent(MsgRec.WParam, MsgRec.LParam); > WM_DEVICECHANGE: > MsgRec.Result := DoDeviceEvent(MsgRec.WParam, MsgRec.LParam); > else > MsgRec.Result := DefWindowProc(FServiceWindow, > MsgRec.Msg, MsgRec.WParam, MsgRec.LParam); > end; > except > on E: Exception do > begin > if DoRunException(E, CanAbort) then > LogMessage(Format(SServiceFailed, > ['Message $' + IntToHex(MsgRec.Msg, 8), E.Message])); > if CanAbort then > Abort; > end; 389c938 < { TService } --- > { TDDService } 391c940 < constructor TService.CreateNew(AOwner: TComponent; Dummy: Integer); --- > constructor TDDService.Create(AOwner: TComponent); 393c942,949 < inherited CreateNew(AOwner); --- > { This dummy exists only to get C++ Builder working correctly otherwise } > { some non-initialized string and set properties. } > inherited Create(AOwner); > end; > > constructor TDDService.CreateNew(AOwner: TComponent; Dummy: Integer = 0); > begin > inherited CreateNew(AOwner, Dummy); 403a960,967 > FFailureOptions := TFailureOptions.Create; > FFailureActions := TFailureActions.Create(Self); > FPreShutdownTimeout := DEFAULT_PRESHUTDOWN_TIMEOUT; > FRequiredPrivileges := TStringList.Create; > FImagePath := ExpandUNCFileName(ParamStr(0)); > if Pos(' ', FImagePath) > 0 then > FImagePath := '"' + FImagePath + '"'; > FExOptions := [eoSuspendServiceThreadOnPause]; 406c970 < destructor TService.Destroy; --- > destructor TDDService.Destroy; 410a975,977 > FFailureOptions.Free; > FFailureActions.Free; > FRequiredPrivileges.Free; 414c981 < function TService.GetDisplayName: String; --- > function TDDService.GetDisplayName: String; 422c989,1004 < procedure TService.SetInteractive(Value: Boolean); --- > function TDDService.GetServiceName: String; > begin > if FServiceName <> '' then > Result := FServiceName > else > Result := Name; > end; > > procedure TDDService.SetServiceName(const Value: String); > begin > if not IsValidServiceName(Value) then > raise Exception.CreateResFmt(@SInvalidServiceName, [Value]); > FServiceName := Value; > end; > > procedure TDDService.SetInteractive(Value: Boolean); 433c1015 < procedure TService.SetPassword(const Value: string); --- > procedure TDDService.SetPassword(const Value: String); 441c1023 < procedure TService.SetServiceStartName(const Value: string); --- > procedure TDDService.SetServiceStartName(const Value: String); 449c1031 < procedure TService.SetDependencies(Value: TDependencies); --- > procedure TDDService.SetDependencies(Value: TDependencies); 454c1036 < function TService.AreDependenciesStored: Boolean; --- > function TDDService.AreDependenciesStored: Boolean; 459c1041,1046 < function TService.GetParamCount: Integer; --- > function TDDService.AreFailureActionsStored: Boolean; > begin > Result := FFailureActions.Count > 0; > end; > > function TDDService.GetParamCount: Integer; 464c1051 < function TService.GetParam(Index: Integer): String; --- > function TDDService.GetParam(Index: Integer): String; 469c1056 < procedure TService.SetOnContinue(Value: TContinueEvent); --- > procedure TDDService.SetOnContinue(Value: TContinueEvent); 475c1062 < procedure TService.SetOnPause(Value: TPauseEvent); --- > procedure TDDService.SetOnPause(Value: TPauseEvent); 481c1068 < procedure TService.SetOnStop(Value: TStopEvent); --- > procedure TDDService.SetOnStop(Value: TStopEvent); 487c1074,1128 < function TService.GetTerminated: Boolean; --- > procedure TDDService.SetOnConsoleEvent(Value: TConsoleEvent); > begin > if Assigned(Value) then > begin > if Assigned(FServiceThread) and (FConsoleHandler = nil) then > begin > FConsoleHandler := @GetConsoleCtrlHandler(); > if not SetConsoleCtrlHandler(FConsoleHandler, True) then > begin > FConsoleHandler := nil; > RaiseLastOSError; > end; > if (eoSynchronizeConsoleEvents in FExOptions) then > CheckCreateServiceThreadWindow; > end; > end > else if Assigned(FConsoleHandler) then > begin > SetConsoleCtrlHandler(FConsoleHandler, False); > FConsoleHandler := nil; > end; > FOnConsoleEvent := Value; > end; > > procedure TDDService.SetOnParamChange(Value: TServiceEvent); > begin > FOnParamChange := Value; > FAllowedExControls := FAllowedExControls + [alParamChange]; > end; > > procedure TDDService.SetOnPowerEvent(Value: TMessageEvent); > begin > FOnPowerEvent := Value; > if Assigned(Value) then CheckCreateServiceThreadWindow; > end; > > procedure TDDService.SetOnDeviceEvent(Value: TMessageEvent); > begin > FOnDeviceEvent := Value; > if Assigned(Value) then CheckCreateServiceThreadWindow; > end; > > procedure TDDService.SetOnPreShutDown(Value: TServiceEvent); > begin > FOnPreShutdown := Value; > FAllowedExControls := FAllowedExControls + [alPreShutdown]; > end; > > procedure TDDService.SetOnSessionChange(Value: TSessionChangeEvent); > begin > FOnSessionChange := Value; > FAllowedExControls := FAllowedExControls + [alSessionChange]; > end; > > function TDDService.GetTerminated: Boolean; 494c1135 < function TService.GetNTDependencies: String; --- > function TDDService.GetNTDependencies: String; 525d1165 < function TService.GetNTServiceType: Integer; 527c1167 < NTServiceType: array[TServiceType] of Integer = ( SERVICE_WIN32_OWN_PROCESS, --- > NTServiceType: array[TServiceType] of DWORD = ( SERVICE_WIN32_OWN_PROCESS, 528a1169,1170 > > function TDDService.GetNTServiceType: DWORD; 537d1178 < function TService.GetNTStartType: Integer; 539c1180 < NTStartType: array[TStartType] of Integer = (SERVICE_BOOT_START, --- > NTStartType: array[TStartType] of DWORD = (SERVICE_BOOT_START, 541c1182,1184 < SERVICE_DISABLED); --- > SERVICE_DISABLED, SERVICE_AUTO_START); > > function TDDService.GetNTStartType: DWORD; 548c1191 < function TService.GetNTErrorSeverity: Integer; --- > function TDDService.GetNTErrorSeverity: DWORD; 550c1193 < NTErrorSeverity: array[TErrorSeverity] of Integer = (SERVICE_ERROR_IGNORE, --- > NTErrorSeverity: array[TErrorSeverity] of DWORD = (SERVICE_ERROR_IGNORE, 556c1199 < function TService.GetNTControlsAccepted: Integer; --- > function TDDService.GetNTControlsAccepted: DWORD; 560a1204,1221 > > if IsWin2K then > begin > if alParamChange in FAllowedExControls then > Result := Result or SERVICE_ACCEPT_PARAMCHANGE; > if (alNetBindChange in FAllowedExControls) then > Result := Result or SERVICE_ACCEPT_NETBINDCHANGE; > if IsWinXP then > begin > if (alSessionChange in FAllowedExControls) then > Result := Result or SERVICE_ACCEPT_SESSIONCHANGE; > if IsWinVista then > begin > if alPreShutdown in FAllowedExControls then > Result := Result or SERVICE_ACCEPT_PRESHUTDOWN; > end; > end; > end; 563c1224,1230 < procedure TService.LogMessage(Message: String; EventType: DWord; Category, ID: Integer); --- > procedure TDDService.LogMessage(Msg: String; > {$IFNDEF COMPATIBILITY} > EventType: TEventLogType; > {$ELSE} > EventType: DWord; > {$ENDIF} > Category, ID: Integer); 566,567c1233,1234 < FEventLogger := TEventLogger.Create(Name); < FEventLogger.LogMessage(Message, EventType, Category, ID); --- > FEventLogger := TEventLogger.Create(ServiceName); > FEventLogger.LogMessage(Msg, EventType, Category, ID); 570d1236 < procedure TService.ReportStatus; 573,575c1239,1241 < NTServiceStatus: array[TCurrentStatus] of Integer = (SERVICE_STOPPED, < SERVICE_START_PENDING, SERVICE_STOP_PENDING, SERVICE_RUNNING, < SERVICE_CONTINUE_PENDING, SERVICE_PAUSE_PENDING, SERVICE_PAUSED); --- > NTServiceStatus: array[TCurrentStatus] of DWORD = (SERVICE_STOPPED, > SERVICE_START_PENDING, SERVICE_STOP_PENDING, SERVICE_RUNNING, > SERVICE_CONTINUE_PENDING, SERVICE_PAUSE_PENDING, SERVICE_PAUSED); 577,579c1243,1247 < csContinuePending, csPausePending]; < var < ServiceStatus: TServiceStatus; --- > csContinuePending, csPausePending]; > > procedure TDDService.ReportStatus; > {var > ServiceStatus: TServiceStatus; } 581c1249 < with ServiceStatus do --- > with FServiceStatus do 586c1254,1255 < dwControlsAccepted := 0 else --- > dwControlsAccepted := 0 > else 587a1257 > 589c1259,1260 < Inc(dwCheckPoint) else --- > Inc(dwCheckPoint) > else 597,598c1268,1269 < if not SetServiceStatus(FStatusHandle, ServiceStatus) then < LogMessage(SysErrorMessage(GetLastError)); --- > if not SetServiceStatus(FStatusHandle, FServiceStatus) then > LogMessage('ReportStatus: ' + SysErrorMessage(GetLastError)); 602c1273 < procedure TService.SetStatus(Value: TCurrentStatus); --- > procedure TDDService.SetStatus(Value: TCurrentStatus); 609c1280,1294 < procedure TService.Main(Argc: DWord; Argv: PLPSTR); --- > procedure TDDService.Stop; > begin > if Assigned(ServiceThread) then > begin > if ServiceThread.Suspended then ServiceThread.Resume; > PostThreadMessage(ServiceThread.ThreadID, > CM_SERVICE_CONTROL_CODE, SERVICE_CONTROL_STOP, 0); > end; > end; > > {$IFDEF COMPILER16_UP} > procedure TDDService.Main(Argc: DWord; Argv: PLPWSTR); > {$ELSE} > procedure TDDService.Main(Argc: DWord; Argv: PLPSTR); > {$ENDIF} 615c1300 < Controller: TServiceController; --- > Controller: Pointer; 619,620c1304,1314 < Controller := GetServiceController(); < FStatusHandle := RegisterServiceCtrlHandler(PChar(Name), @Controller); --- > { Windows 7 and better. Are we started by a trigger? } > FTriggerStarted := (Argc > 1) and (PPCharArray(Argv)[1] = SERVICE_TRIGGER_STARTED_ARGUMENT); > if IsWin2K then > begin > Controller := @GetServiceControllerEx(); > FStatusHandle := RegisterServiceCtrlHandlerEx(PChar(ServiceName), Controller, nil); > end > else begin > Controller := @GetServiceController(); > FStatusHandle := RegisterServiceCtrlHandler(PChar(ServiceName), Controller); > end; 627c1321 < procedure TService.Controller(CtrlCode: DWord); --- > procedure TDDService.Controller(CtrlCode: DWord); 629d1322 < PostThreadMessage(ServiceThread.ThreadID, CM_SERVICE_CONTROL_CODE, CtrlCode, 0); 630a1324 > PostThreadMessage(ServiceThread.ThreadID, CM_SERVICE_CONTROL_CODE, CtrlCode, 0); 633c1327,1408 < procedure TService.DoStart; --- > function TDDService.ControllerEx(CtrlCode, EventType: DWord; EventData, > Context: Pointer): DWord; > var > WP: WPARAM; > LP: LPARAM; > Msg: UINT; > begin > LP := 0; > Msg := CM_SERVICE_CONTROL_CODE; > WP := CtrlCode; > Result := ERROR_CALL_NOT_IMPLEMENTED; > > case CtrlCode of > SERVICE_CONTROL_CONTINUE, > SERVICE_CONTROL_PAUSE : > if FAllowPause then > Result := NO_ERROR; > > SERVICE_CONTROL_STOP : > if FAllowStop then > Result := NO_ERROR; > > SERVICE_CONTROL_INTERROGATE, > SERVICE_CONTROL_SHUTDOWN : > Result := NO_ERROR; > > SERVICE_CONTROL_PARAMCHANGE : > if alParamChange in FAllowedExControls then > Result := NO_ERROR; > > SERVICE_CONTROL_NETBINDADD, > SERVICE_CONTROL_NETBINDREMOVE, > SERVICE_CONTROL_NETBINDENABLE, > SERVICE_CONTROL_NETBINDDISABLE : > if alNetBindChange in FAllowedExControls then > Result := NO_ERROR; > > SERVICE_CONTROL_SESSIONCHANGE : > if alSessionChange in FAllowedExControls then > begin > Msg := CM_SERVICE_CONTROL_SESSIONCHANGE; > WP := EventType; > LP := PWtsSessionNotification(EventData)^.dwSessionId; > Result := NO_ERROR; > end; > > SERVICE_CONTROL_PRESHUTDOWN : > if alPreShutdown in FAllowedExControls then > Result := NO_ERROR; > > else // case > if CtrlCode in [CUSTOMCONTROL_LOW..CUSTOMCONTROL_HIGH] then > Result := NO_ERROR > else > Exit; > end; // case > > if Result = NO_ERROR then > begin > if ServiceThread.Suspended then ServiceThread.Resume; > PostThreadMessage(ServiceThread.ThreadID, Msg, WP, LP); > end; > end; > > function TDDService.ConsoleCtrlHandler(Ctrl: DWord): LongBool; > begin > Result := False; > if FStatus in [csStopped, csStartPending] then Exit; > if (eoSynchronizeConsoleEvents in FExOptions) then > begin > if (FServiceWindow <> 0) then > begin > if ServiceThread.Suspended then ServiceThread.Resume; > Cardinal(Result) := SendMessage(FServiceWindow, > CM_SERVICE_CONSOLE_CTRL, Ctrl, 0); > end; > end > else > Result := DoConsoleEvent(Ctrl); > end; > > procedure TDDService.DoStart; 651c1426 < function TService.DoStop: Boolean; --- > function TDDService.DoStop: Boolean; 659c1434,1459 < function TService.DoPause: Boolean; --- > function TDDService.DoContinue: Boolean; > begin > Result := True; > Status := csContinuePending; > if Assigned(FOnContinue) then FOnContinue(Self, Result); > if Result then > Status := csRunning; > end; > > procedure TDDService.DoInterrogate; > begin > ReportStatus; > end; > > procedure TDDService.DoShutdown; > begin > Status := csStopPending; > try > if Assigned(FOnShutdown) then FOnShutdown(Self); > finally > { Shutdown cannot abort, it must stop regardless of any exception } > ServiceThread.Terminate; > end; > end; > > function TDDService.DoPause: Boolean; 667c1467,1468 < ServiceThread.Suspend; --- > if eoSuspendServiceThreadOnPause in FExOptions then > ServiceThread.Suspend; 671c1472 < function TService.DoContinue: Boolean; --- > procedure TDDService.DoCustomControl(CtrlCode: DWord); 672a1474,1504 > if Assigned(FOnCustomControl) then > FOnCustomControl(Self, CtrlCode) > end; > > function TDDService.DoConsoleEvent(CtrlCode: Integer): Boolean; > var > EventProc: TConsoleEvent; > begin > Result := False; > EventProc := FOnConsoleEvent; > if Assigned(EventProc) then > EventProc(Self, CtrlCode, Result); > end; > (* I never received this control neither in W2K, XP nor in Vista > function TDDService.DoHardwareProfileChange(EventType: Integer): Integer; > begin > Result := 0; > if Assigned(FOnHardwareProfileChange) then > FOnHardwareProfileChange(Self, EventType, 0, Result); > end; > *) > function TDDService.DoDeviceEvent(EventType: Integer; EventData: TDDIntPtr): Integer; > begin > Result := 0; > if Assigned(FOnDeviceEvent) and (Status <> csStartPending) then > FOnDeviceEvent(Self, EventType, EventData, Result); > end; > > function TDDService.DoRunException(E: Exception; var CanAbort: Boolean): Boolean; > begin > CanAbort := False; 674,677c1506,1507 < Status := csContinuePending; < if Assigned(FOnContinue) then FOnContinue(Self, Result); < if Result then < Status := csRunning; --- > if Assigned(FOnRunException) then > FOnRunException(Self, E, Result, CanAbort); 680c1510 < procedure TService.DoInterrogate; --- > procedure TDDService.DoParamChange; 682a1513,1514 > if Assigned(FOnParamChange) then > FOnParamChange(Self); 685c1517,1524 < procedure TService.DoShutdown; --- > function TDDService.DoPowerEvent(EventType: Integer; EventData: TDDIntPtr): Integer; > begin > Result := 0; > if Assigned(FOnPowerEvent) and (Status <> csStartPending) then > FOnPowerEvent(Self, EventType, EventData, Result); > end; > > procedure TDDService.DoPreShutdown; 689c1528 < if Assigned(FOnShutdown) then FOnShutdown(Self); --- > if Assigned(FOnPreShutdown) then OnPreShutdown(Self); 691c1530 < { Shutdown cannot abort, it must stop regardless of any exception } --- > { PreShutdown cannot abort, it must stop regardless of any exception } 696c1535,1601 < function TService.DoCustomControl(CtrlCode: DWord): Boolean; --- > procedure TDDService.DoNetBindChange(EventType: Integer); > begin > ReportStatus; > if Assigned(FOnNetBindChange) then > FOnNetBindChange(Self, EventType); > end; > > procedure TDDService.DoSessionChange(EventType, SessionID: Integer); > begin > ReportStatus; > if Assigned(FOnSessionChange) then > FOnSessionChange(Self, EventType, SessionID); > end; > > procedure TDDService.SetDescription(const Value: String); > begin > if Length(Value) >= 1024 then > raise Exception.Create(SInvalidServiceDescription); > FDescription := Value; > end; > > procedure TDDService.SetFailureActions(Value: TFailureActions); > begin > FFailureActions.Assign(Value); > end; > > procedure TDDService.SetFailureOptions(Value: TFailureOptions); > begin > FFailureOptions.Assign(Value); > end; > > procedure TDDService.SetRequiredPrivileges(Value: TStrings); > begin > FRequiredPrivileges.Assign(Value); > end; > > procedure TDDService.SetOnNetBindChange(Value: TControlEvent); > begin > FOnNetBindChange := Value; > FAllowedExControls := FAllowedExControls + [alNetBindChange]; > end; > > procedure TDDService.SetExOptions(Value: TExOptions); > begin > FExOptions := Value; > if (eoForceServiceThreadWindow in FExOptions) or > (Assigned(FOnConsoleEvent) and (eoSynchronizeConsoleEvents in FExOptions)) then > CheckCreateServiceThreadWindow; > end; > > function TDDService.ThreadWindowNeeded: Boolean; > begin > Result := (eoForceServiceThreadWindow in FExOptions) or > Assigned(FOnPowerEvent) or Assigned(FOnDeviceEvent) or > (Assigned(FOnConsoleEvent) and (eoSynchronizeConsoleEvents in FExOptions)); > end; > > procedure TDDService.CheckCreateServiceThreadWindow; > begin > if Assigned(FServiceThread) and (FServiceWindow = 0) then > begin > FServiceWindow := AllocateHwnd; > if FServiceWindow = 0 then raise Exception.Create(SFailureCreateWindow); > end; > end; > > procedure TDDService.DestroyServiceThreadWindow; 697a1603,1619 > if (FServiceWindow <> 0) then > begin > DeallocateHWnd(FServiceWindow); > FServiceWindow := 0; > end; > end; > > function IsValidServiceName(const SvcName: string): Boolean; > var > I: Integer; > begin > Result := False; > if (Length(SvcName) = 0) or (Length(SvcName) > 256) then Exit; > for I := 1 to Length(SvcName) do > case SvcName[I] of > '\', '/' : Exit; > end; 704c1626 < TServiceClass = class of TService; --- > TDDServiceClass = class of TDDService; 705a1628,1630 > {$IFDEF COMPILER16_UP} > procedure ServiceMain(Argc: DWord; Argv: PLPWSTR); stdcall; > {$ELSE} 706a1632 > {$ENDIF} 712a1639,1641 > {$IFDEF COMPILER16_UP} > with Vcl.Forms.Application do > {$ELSE} 713a1643 > {$ENDIF} 733c1663 < Forms.Application.HookMainWindow(Hook); --- > {$IFDEF COMPILER16_UP}Vcl.{$ENDIF}Forms.Application.HookMainWindow(Hook); 739,740c1669,1671 < Forms.Application.OnException := nil; < Forms.Application.UnhookMainWindow(Hook); --- > FEventLogger := nil; > {$IFDEF COMPILER16_UP}Vcl.{$ENDIF}Forms.Application.OnException := nil; > {$IFDEF COMPILER16_UP}Vcl.{$ENDIF}Forms.Application.UnhookMainWindow(Hook); 743a1675,1677 > {$IFDEF COMPILER16_UP} > procedure TServiceApplication.DispatchServiceMain(Argc: DWord; Argv: PLPWSTR); > {$ELSE} 744a1679 > {$ENDIF} 749,750c1684,1685 < if (Components[i] is TService) and < (AnsiCompareText(PChar(Argv^), Components[i].Name) = 0) then --- > if (Components[i] is TDDService) and > (AnsiCompareText(PChar(Argv^), TDDService(Components[i]).ServiceName) = 0) then 752c1687 < TService(Components[i]).Main(Argc, Argv); --- > TDDService(Components[i]).Main(Argc, Argv); 763c1698 < if Components[i] is TService then --- > if Components[i] is TDDService then 766a1702,1846 > function EnableShutdownPrivilege: Boolean; > var > hToken: THandle; > NewState: TTokenPrivileges; > OldState: PTokenPrivileges; > RetLen: DWord; > Luid: TLargeInteger; > begin > Result := False; > if OpenProcessToken(GetCurrentProcess, > TOKEN_ADJUST_PRIVILEGES, hToken) then > try > if not LookupPrivilegeValue(nil, SE_SHUTDOWN_NAME , Luid) then > Exit; > NewState.PrivilegeCount := 1; > NewState.Privileges[0].Luid := Luid; > NewState.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED; > OldState := nil; > RetLen := 0; > if AdjustTokenPrivileges(hToken, False, NewState, SizeOf(TTokenPrivileges), > OldState, RetLen) then > Result := True; > finally > CloseHandle(hToken); > end; > end; > > procedure TServiceApplication.ChangeServiceConfiguration2(Service: TDDService; > hService: THandle); > var > ADescription: TServiceDescription; > AFailureActions: TServiceFailureActions; > AFailureActionsFlag: TServiceFailureActionsFlag; > APreShutdownInfo: TServicePreShutDownInfo; > ADelayedAutoStartInfo: TServiceDelayedAutoStartInfo; > ASidInfo: TServiceSidInfo; > ARequiredPrivilegesInfo: TServiceRequiredPrivilegesInfo; > PActions: PScAction; > Action: TFailureAction; > I: Integer; > ShutdownFlag: Boolean; > begin > with Service do > begin > // Win 2000 > if IsWin2K then > begin > ADescription.lpDescription := PChar(FDescription); > if not ChangeServiceConfig2(hService, SERVICE_CONFIG_DESCRIPTION, > @ADescription) then > raise Exception.CreateFmt(SServiceConfigError, > [SysErrorMessage(GetLastError), SDescription]); > > if FailureOptions.FResetPeriod < 0 then > AFailureActions.dwResetPeriod := INFINITE > else > AFailureActions.dwResetPeriod := FailureOptions.ResetPeriod; > > AFailureActions.lpRebootMsg := PChar(FailureOptions.FRebootMessage); > AFailureActions.lpCommand := PChar(FailureOptions.FCommand); > AFailureActions.cActions := FailureActions.Count; > > I := SizeOf(TScAction) * FailureActions.Count; > GetMem(PActions, I); > try > ZeroMemory(PActions, I); > AFailureActions.lpsaActions := PActions; > ShutdownFlag := False; > for I := 0 to FailureActions.Count -1 do > begin > Action := FailureActions[I]; > PActions^.Type_ := ActionTypes[Action.ActionType]; > PActions^.Delay := Action.Delay; > Inc(PActions); > ShutdownFlag := ShutdownFlag or (Action.ActionType = faReboot); > end; > { SE_SHUTDOWN_NAME is required and must be enabled ! } > if ShutdownFlag then > if not EnableShutdownPrivilege then > raise Exception.CreateFmt(SServiceConfigError, > [SysErrorMessage(GetLastError), > SRecoveryOptions]); > if not ChangeServiceConfig2(hService, SERVICE_CONFIG_FAILURE_ACTIONS, > @AFailureActions) then > raise Exception.CreateFmt(SServiceConfigError, > [SysErrorMessage(GetLastError), > SRecoveryOptions]); > finally > FreeMem(AFailureActions.lpsaActions); > end; > > // Win Vista > if IsWinVista then > begin > // LongBool must be either 0 or 1! > Cardinal(AFailureActionsFlag.fFailureActionsOnNonCrashFailures) := > Ord(FailureOptions.FNonCrashFailures); > if not ChangeServiceConfig2(hService, SERVICE_CONFIG_FAILURE_ACTIONS_FLAG, > @AFailureActionsFlag) then > raise Exception.CreateFmt(SServiceConfigError, > [SysErrorMessage(GetLastError), > SNonCrashFailures]); > APreShutdownInfo.dwPreshutdownTimeout := FPreShutdownTimeout; > if not ChangeServiceConfig2(hService, SERVICE_CONFIG_PRESHUTDOWN_INFO, > @APreShutdownInfo) then > raise Exception.CreateFmt(SServiceConfigError, > [SysErrorMessage(GetLastError), > SPreshutdownTimeout]); > // LongBool must be either 0 or 1! > Cardinal(ADelayedAutoStartInfo.fDelayedAutostart) := > Ord(FStartType = stAutoDelayed); > if not ChangeServiceConfig2(hService, > SERVICE_CONFIG_DELAYED_AUTO_START_INFO, > @ADelayedAutoStartInfo) then > raise Exception.CreateFmt(SServiceConfigError, > [SysErrorMessage(GetLastError), > SDelayedAutoStart]); > case ServiceSidType of > stUnrestricted: ASidInfo.dwServiceSidType := > SERVICE_SID_TYPE_UNRESTRICTED; > stRestricted: ASidInfo.dwServiceSidType := > SERVICE_SID_TYPE_RESTRICTED; > else > ASidInfo.dwServiceSidType := SERVICE_SID_TYPE_NONE; > end; > if not ChangeServiceConfig2(hService, SERVICE_CONFIG_SERVICE_SID_INFO, > @ASidInfo) then > raise Exception.CreateFmt(SServiceConfigError, > [SysErrorMessage(GetLastError), > SServiceSidType]); > > ARequiredPrivilegesInfo.pmszRequiredPrivileges := > PChar(StrToMultiSZ(FRequiredPrivileges)); > if not ChangeServiceConfig2(hService, > SERVICE_CONFIG_REQUIRED_PRIVILEGES_INFO, > @ARequiredPrivilegesInfo) then > raise Exception.CreateFmt(SServiceConfigError, > [SysErrorMessage(GetLastError), > SRequiredPrivileges]); > > end; // Vista > end; // Win2000 > end; > end; > 769c1849 < procedure InstallService(Service: TService; SvcMgr: Integer); --- > procedure InstallService(Service: TDDService; SvcMgr: SC_HANDLE); 771,773c1851,1854 < TmpTagID, Svc: Integer; < PTag, PSSN: Pointer; < Path: string; --- > TmpTagID: DWORD; > PTag: PDWORD; > PSSN: PChar; > Svc: SC_HANDLE; 775d1855 < Path := ParamStr(0); 778a1859 > 780a1862 > 782c1864,1865 < PSSN := nil else --- > PSSN := nil > else 784,787c1867,1881 < Svc := CreateService(SvcMgr, PChar(Name), PChar(DisplayName), < SERVICE_ALL_ACCESS, GetNTServiceType, GetNTStartType, GetNTErrorSeverity, < PChar(Path), PChar(LoadGroup), PTag, PChar(GetNTDependencies), < PSSN, PChar(Password)); --- > > Svc := CreateService(SvcMgr, > PChar(ServiceName), > PChar(DisplayName), > SERVICE_ALL_ACCESS, > GetNTServiceType, > GetNTStartType, > GetNTErrorSeverity, > PChar(ImagePath), > PChar(LoadGroup), > PTag, > PChar(GetNTDependencies), > PSSN, > PChar(Password)); > 788a1883 > 792a1888 > ChangeServiceConfiguration2(Service, Svc); 807c1903 < procedure UninstallService(Service: TService; SvcMgr: Integer); --- > procedure UninstallService(Service: TDDService; SvcMgr: SC_HANDLE); 809c1905 < Svc: Integer; --- > Svc: SC_HANDLE; 814c1910 < Svc := OpenService(SvcMgr, PChar(Name), SERVICE_ALL_ACCESS); --- > Svc := OpenService(SvcMgr, PChar(ServiceName), SERVICE_ALL_ACCESS); 824a1921,1927 > procedure DisplayMessage(const Msg: string; const MsgType: TMsgDlgType); > begin > if IsConsole then > WriteLn(Msg) > else > MessageDlg(Msg, MsgType, [mbOk], 0); > end; 827c1930 < SvcMgr: Integer; --- > SvcMgr: SC_HANDLE; 837c1940 < if Components[i] is TService then --- > if Components[i] is TDDService then 840,841c1943,1945 < InstallService(TService(Components[i]), SvcMgr) else < UninstallService(TService(Components[i]), SvcMgr) --- > InstallService(TDDService(Components[i]), SvcMgr) > else > UninstallService(TDDService(Components[i]), SvcMgr); 847c1951,1952 < Msg := SServiceInstallFailed else --- > Msg := SServiceInstallFailed > else 849,850c1954,1955 < with TService(Components[i]) do < MessageDlg(Format(Msg, [DisplayName, E.Message]), mtError, [mbOK],0); --- > with TDDService(Components[i]) do > DisplayMessage(Format(Msg, [DisplayName, E.Message]), mtError); 855,856c1960,1962 < MessageDlg(SServiceInstallOK, mtInformation, [mbOk], 0) else < MessageDlg(SServiceUninstallOK, mtInformation, [mbOk], 0); --- > DisplayMessage(SServiceInstallOK, mtInformation) > else > DisplayMessage(SServiceUninstallOK, mtInformation); 870c1976 < if InstanceClass.InheritsFrom(TService) then --- > if InstanceClass.InheritsFrom(TDDService) then 879c1985 < Forms.Application.CreateForm(InstanceClass, Reference); --- > {$IFDEF COMPILER16_UP}Vcl.{$ENDIF}Forms.Application.CreateForm(InstanceClass, Reference); 892,893c1998,1999 < Forms.Application.ShowMainForm :=False; < Forms.Application.Initialize; --- > {$IFDEF COMPILER16_UP}Vcl.{$ENDIF}Forms.Application.ShowMainForm := False; > {$IFDEF COMPILER16_UP}Vcl.{$ENDIF}Forms.Application.Initialize; 907a2014,2015 > var > Handled : Boolean; 909c2017,2021 < DoHandleException(E); --- > Handled := FALSE; > if Assigned(FOnException) then > FOnException(Sender, E, Handled); > if not Handled then > DoHandleException(E); 936c2048 < PostMessage(Forms.Application.Handle, WM_QUIT, 0, 0); --- > PostMessage({$IFDEF COMPILER16_UP}Vcl.{$ENDIF}Forms.Application.Handle, WM_QUIT, 0, 0); 960c2072 < Forms.Application.OnException := OnExceptionHandler; --- > {$IFDEF COMPILER16_UP}Vcl.{$ENDIF}Forms.Application.OnException := OnExceptionHandler; 963c2075 < if Components[i] is TService then Inc(ServiceCount); --- > if Components[i] is TDDService then Inc(ServiceCount); 968c2080 < if Components[i] is TService then --- > if Components[i] is TDDService then 970c2082 < ServiceStartTable[J].lpServiceName := PChar(Components[i].Name); --- > ServiceStartTable[J].lpServiceName := PChar(TDDService(Components[i]).ServiceName); 976c2088 < while not Forms.Application.Terminated do --- > while not {$IFDEF COMPILER16_UP}Vcl.{$ENDIF}Forms.Application.Terminated do 978c2090 < Forms.Application.HandleMessage; --- > {$IFDEF COMPILER16_UP}Vcl.{$ENDIF}Forms.Application.HandleMessage; 983c2095 < Forms.Application.Terminate; --- > {$IFDEF COMPILER16_UP}Vcl.{$ENDIF}Forms.Application.Terminate; 1002a2115,2195 > { TFailureAction } > > procedure TFailureAction.Assign(Source: TPersistent); > begin > if Source is TFailureAction then > begin > Delay := TFailureAction(Source).Delay; > ActionType := TFailureAction(Source).ActionType; > end else > inherited Assign(Source); > end; > > function TFailureAction.GetDisplayName: String; > begin > case FActionType of > faReboot : Result := Format(SFailureReboot, [FDelay]); > faRestart : Result := Format(SFailureRestart, [FDelay]); > faRunCommand : result := Format(SFailureExecute, [FDelay]); > else > Result := SFailureNoAction; > end; > end; > > procedure TFailureAction.SetActionType(Value: TFailureActionType); > begin > FActionType := Value; > if FActionType = faNone then > FDelay := 0; > end; > > procedure TFailureAction.SetDelay(Value: Integer); > begin > if Value < 0 then > FDelay := 0 > else > FDelay := Value; > end; > > { TFailureActions } > > function TFailureActions.Add: TFailureAction; > begin > Result := TFailureAction.Create(Self); > end; > > constructor TFailureActions.Create(AOwner: TPersistent); > begin > inherited Create(TFailureAction); > FOwner := AOwner; > end; > > function TFailureActions.GetItems(Index: Integer): TFailureAction; > begin > Result := inherited Items[Index] as TFailureAction; > end; > > function TFailureActions.GetOwner: TPersistent; > begin > Result := FOwner; > end; > > { TFailureOptions } > > procedure TFailureOptions.Assign(Source: TPersistent); > begin > if Source is TFailureOptions then > begin > FResetPeriod := TFailureOptions(Source).FResetPeriod; > FRebootMessage := TFailureOptions(Source).FRebootMessage; > FCommand := TFailureOptions(Source).FCommand; > FNonCrashFailures := TFailureOptions(Source).FNonCrashFailures; > end else > inherited; > end; > > constructor TFailureOptions.Create; > begin > inherited; > FResetPeriod := -1; > end; > 1003a2197 > InitializeCriticalSection(CritSectWndClass); 1004a2199 > 1005a2201 > DeleteCriticalSection(CritSectWndClass);