精华内容
下载资源
问答
  • delphi服务TService

    千次阅读 2018-07-24 11:25:52
    属性介绍 allowpause 表明服务是否允许暂停。true则scp(服务控制面板)上的暂停按钮是可用的,false则是不可用的 allowstop 表明服务是否允许停止。true则scp(服务控制模板)上的停止按钮时可用的,false则是不...

    属性介绍

    allowpause 表明服务是否允许暂停。true则scp(服务控制面板)上的暂停按钮是可用的,false则是不可用的

    allowstop 表明服务是否允许停止。true则scp(服务控制模板)上的停止按钮时可用的,false则是不可用的

    dependencies 用于列出所有要依赖的服务

    displayname 显示在scp上的服务名称

    errcode 指定一个错误代码。当遇到错误或提供状态信息时,就返回这个代码。如果errcode的值为0,则使用win32errcode属性

    errorserverity 表明如果启动服务时遇到错误,如何处理

    interactive 表明是否可以显示一个对话框。只适用于win32服务

    name 服务的名称,即服务在scm中的名称。如果要用sc.exe或net.exe来控制一个服务,必须指定服务的名称,而不是displayname指定的名称

    param 启动时的参数列表。用sc.exe来启动服务后,即可在scp中指定参数,也可以从命令行中设置参数

    paramcount 传递个服务的参数个数

    password 用于设置口令。只适合于不使用localsystem账号的服务

    servicestartname 用于设置服务的账号名称,格式:域名/用户名

    servicethread 这是服务内部的线程,用于处理命令和请求

    servicetype 服务的类型,可以设为:stwin32(win32服务),stdevice(设备驱动程序)或stfilesystem(文件系统服务)

    status 服务的当前状况(running,stopped,paused,stop pending)

    terminated 表明内部的线程是否终止

    waithint 服务等待控制命令或状态请求的时间。如果在规定的时间内没有响应,则scm认为服务出错

    win32errcode 当发生错误或errcode属性的值为0时,包含一个系统定义的错误代码

    事件介绍

    afterinstall:安装服务之后调用的方法

    afteruninstall:服务卸载之后调用的方法

    beforeinstall:服务安装之前调用的方法

    beforeuninstall:服务卸载之后调用的方法

    oncontinue:服务暂停继续调用的方法

    onexecute:执行服务开始调用的方法

    onpause:暂停服务调用的方法

    onshutdown:关闭时调用的方法

    onstart:启动服务调用的的方法

    onstop:停止服务调用的方法

    logmessage()函数用于发送一个消息到nt的事件日志中

    reportstatus()函数 用于发送服务的状态信息到scm

     

    展开全文
  • delphi Tservice

    2017-09-21 18:32:50
    TService属性介绍: AllowPause:是否允许暂停; AllowStop:是否允许停止; Dependencies:启动服务时所依赖的服务,如果依赖服务不存在则不能启动服务,而且启动本服务的时候会自动启动依赖服务; DisplayName:...

    TService:

    属性介绍

    AllowPause 表明服务是否允许暂停。True则SCP(服务控制面板)上的暂停按钮时可用的,False则是不可用的 

    AllowStop 表明服务是否允许停止。True则SCP(服务控制面板)上的停止按钮时可用的,False则是不可用的 

    Dependecies 用于列出所有要依赖的服务 

    DisplayName 显示在SCP上的服务名称 

    ErrCode 指定一个错误代码。当遇到错误或提供状态信息时,就返回这个代码。如果ErrCode的值为0,则使用Win32ErrorCode属性。 

    ErrorSeverity 表明如果启动服务时遇到错误,如何处理 

    Interactive 表明是否可以显示一个对话框。只适用于Win32服务 

    Name 服务的名称,即服务在SCM中的名称。如果要用SC.EXE或Net.exe来控制一个服务,必须指定服务的名称,而不是DisplayName指定的名称。 

    Param 启动时的参数列表。用SC.exe来启动服务后,即可在SCP中指定参数,也可以从命令行中设置参数。 

    ParamCount 传递个服务的参数个数 

    Password 用于设置口令。只适合于不使用LoaclSystem账号的服务 

    ServiceStartName 用于设置服务的账号名称,格式:域名/用户名 

    ServiceThread 这是服务内部的线程,用于处理命令和请求 

    ServiceType 服务的类型,可以设为:stWin32(Win32服务),stDevice(设备驱动程序)或stFileSystem(文件系统服务) 

    Status 服务的当前状况(running,stopped,paused,stop pending等) 

    Terminated 表明内部的线程是否终止 

    WaitHint 服务等待控制命令或状态请求的时间。如果在规定的时间内没有响应,则SCM认为服务出错 

    Win32ErrCode 当发生错误或ErrCode属性的值为0时,包含一个系统定义的错误代码


    事件介绍:

    AfterInstall:安装服务之后调用的方法;

    AfterUninstall:服务卸载之后调用的方法;

    BeforeInstall:服务安装之前调用的方法;

    BeforeUninstall:服务卸载之前调用的方法;

    OnContinue:服务暂停继续调用的方法;

    OnExecute:执行服务开始调用的方法;

    OnPause:暂停服务调用的方法;

    OnShutDown:关闭时调用的方法;

    OnStart:启动服务调用的方法;

    OnStop:停止服务调用的方法;

    LogMessage()函数 用于发送一个消息到NT的事件日志种;

    ReportStatus()函数 用于发送服务的状态信息到SCM;
    展开全文
  • 使用TService 、TThread 、TIdSNTP 制作的时间同步服务器客户端
  • 使用Delphi制作Tservice的例子
  • 请问C#中的TService是啥 public interface AntInterface { TService GetService<TService>(); } 我插入这样的代码,可以编译,但是无法查看TService是啥 网上也查不到相关解释资料
  • type TCenterService = class(TService) procedure ServiceStart(Sender: TService; var Started: Boolean); procedure ServiceStop(Sender: TService; var Stopped: Boolean); procedure ServiceExecute(Sender: ...

    说明:  编写一个系统http服务, 供多个终端请求, 并返回相应数据.

             程序划分为服务、服务安装程序、终端。

    控件: 使用了YxdIOCP, 下载地址为(感谢作者的分享): https://github.com/yangyxd/YxdIOCP

    以下对服务、服务安装程序、终端、测试进行单独说明:

    服务:

     

    File-> new-> othor-> ServiceApplication

    工程文件保存为ControlCenter, Unit1.pas保存为uService.pas.

    新建配置文件Server.ini, 添加如下

    [SYSTEM]
    iHttpPort=5000

     

    1.  工程文件ControlCenter内容如下

        需要注意的是,在uses单元引入了Forms单元,方便调试使用(SvcMgr和Forms下都有Application类,在代码底部可看到区别)。

        Release模式下,不会创建窗体。 Debug模式下会创建窗体,方便调试。

    program ControlCenter;
    
    uses
      SvcMgr,
      Forms,
      uService in 'uService.pas' {CenterService: TService},
      uPublic in 'public\uPublic.pas',
      uHttpEvent in 'public\uHttpEvent.pas',
      uServer in 'public\uServer.pas',
      uVar in 'public\uVar.pas',
      uFrmMain in 'form\uFrmMain.pas' {frmMain},
      uAppFactory in 'public\uAppFactory.pas';
    
    {$R *.RES}
    
    var
      sErr: string;
    
    begin
      // Windows 2003 Server requires StartServiceCtrlDispatcher to be
      // called before CoRegisterClassObject, which can be called indirectly
      // by Application.Initialize. TServiceApplication.DelayInitialize allows
      // Application.Initialize to be called from TService.Main (after
      // StartServiceCtrlDispatcher has been called).
      //
      // Delayed initialization of the Application object may affect
      // events which then occur prior to initialization, such as
      // TService.OnCreate. It is only recommended if the ServiceApplication
      // registers a class object with OLE and is intended for use with
      // Windows 2003 Server.
      //
      // Application.DelayInitialize := True;
      //
      {$IFNDEF DEBUG}
        {Release版本}
        SvcMgr.Application.Initialize;
        SvcMgr.Application.CreateForm(TCenterService, CenterService);
        SvcMgr.Application.Run;
      {$ELSE}
        {Debug版本}
        Forms.Application.Initialize;
        AppFactory:= TAppFactory.Create;
        if AppFactory.Factory(sErr) then
          Forms.Application.CreateForm(TfrmMain, frmMain);
        Forms.Application.Run;
    //    AppFactory.Destroy;
      {$ENDIF}
    end.

    2. uService.pas内容如下:

        在ServiceStart方法里完成服务的启动,在factory方法里

       

    unit uService;
    
    interface
    
    uses
      Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs,
      uAppFactory;
    
    type
      TCenterService = class(TService)
        procedure ServiceStart(Sender: TService; var Started: Boolean);
        procedure ServiceStop(Sender: TService; var Stopped: Boolean);
        procedure ServiceExecute(Sender: TService);
      private
        { Private declarations }
      public
        function GetServiceController: TServiceController; override;
        { Public declarations }
      end;
    
    var
      CenterService: TCenterService;
      AppFactory: TAppFactory;
    
    implementation
    
    uses uPublic, uFrmMain, uVar;
    
    {$R *.DFM}
    
    procedure ServiceController(CtrlCode: DWord); stdcall;
    begin
      CenterService.Controller(CtrlCode);
    end;
    
    function TCenterService.GetServiceController: TServiceController;
    begin
      Result := ServiceController;
    end;
    
    procedure TCenterService.ServiceExecute(Sender: TService);
    begin
      while not Terminated do
      begin
        systemLog('ServiceExecute');
        Sleep(5000);
      end;
    end;
    
    procedure TCenterService.ServiceStart(Sender: TService; var Started: Boolean);
    var
      sErr: string;
    begin
      AppFactory:= TAppFactory.Create;
      AppFactory.Factory(sErr);
      Started:= True;
      systemLog('ServiceStart');
    end;
    
    procedure TCenterService.ServiceStop(Sender: TService; var Stopped: Boolean);
    begin
      if Assigned(AppFactory) then
        FreeAndNil(AppFactory);
      Stopped:= True;
      systemLog('ServiceStop');
    end;
    
    end.

    3. uPublic.pas内容如下

    unit uPublic;
    
    interface
    
    uses Windows, SysUtils, iocp.Http, superobject;
    
    procedure ProcessMessage;
    //写日志
    procedure systemLog(Msg: string);
    
    function getParam(Request: TIocpHttpRequest; sParam :string):string;
    
    implementation
    
    //1.3.7.0   防止切换输入法等引起程序假死
    procedure ProcessMessage;
    var
      Msg: TMsg;
    begin
      if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
      begin
        TranslateMessage(Msg);
        DispatchMessage(Msg);
      end;
    end;
    
    procedure systemLog(Msg: string);
    var
      F: TextFile;
      FileName: string;
      ExeRoad: string;
    begin
      try
        ExeRoad := ExtractFilePath(ParamStr(0));
        if ExeRoad[Length(ExeRoad)] = '\' then
          SetLength(ExeRoad, Length(ExeRoad) - 1);
        if not DirectoryExists(ExeRoad + 'log') then
        begin
          CreateDir(ExeRoad + '\log');
        end;
        FileName := ExeRoad + '\log\_Log' + FormatDateTime('YYMMDD', NOW) + '.txt';
        if not FileExists(FileName) then
        begin
          AssignFile(F, FileName);
          ReWrite(F);
        end
        else
          AssignFile(F, FileName);
        Append(F);
        Writeln(F, FormatDateTime('HH:NN:SS.zzz ', Now) + Msg);
        CloseFile(F);
      except
        //可能在事务中调用,避免意外
        Exit;
      end;
    end;
    
    function getParam(Request: TIocpHttpRequest; sParam :string):string;
    var
     js :ISuperObject;
    begin
      Result := '';
      if Request.ContentType = 'application/json' then
      begin
        js := SO(UTF8Decode(Request.DataString));
        if js <> nil then
        if js[sParam] <> nil then
        Result := js[sParam].AsString;
      end
      else
      begin
        Result := Request.GetParam(sParam);
      end;
    end;
    
    end.

    4. uHttpEvent.pas内容如下

        定义事件处理类,包含了心跳, 获取服务时间, 数据返回。 方便测试使用。

    unit uHttpEvent;
    
    interface
    
    uses
      iocp, iocp.Http, superobject, SysUtils;
    
    type
      THttpEvent= class
        //心跳
        class function _Heart(request: TIocpHttpRequest; response: TIocpHttpResponse): Boolean;
        //获取服务时间
        class function _GetServerTime(request: TIocpHttpRequest; response: TIocpHttpResponse): Boolean;
        //返回数据
        class function _HttpSend(response: TIocpHttpResponse; sSend: string): Boolean;
      end;
    
    implementation
    
    uses uPublic;
    
    { THttpEvent }
    
    class function THttpEvent._GetServerTime(request: TIocpHttpRequest;
      response: TIocpHttpResponse): Boolean;
    var
      sMethod, sCode, sMsg, sAppkey, sSend: string;
      vJs, tJs: ISuperObject;
    begin
      sCode:= '9001';
      sMsg:= 'Unknown error';
      sMethod:= 'servertime';
      try
        sAppkey:= GetParam(request, 'appKey');
        sCode:= '9000';
        sMsg:= 'Success';
      finally
        tJs:= TSuperObject.Create;
        tJs.S['code']:= sCode;
        tJs.S['message']:= sMsg;
        tJs.S['sMethod']:= sMethod;
        tJs.S['servertime']:= FormatDateTime('YYYY-MM-DD hh:mm:ss', Now);
        sSend:= tJs.AsString;
        _HttpSend(response, sSend);
      end;
    end;
    
    class function THttpEvent._Heart(request: TIocpHttpRequest;
      response: TIocpHttpResponse): Boolean;
    var
      sMethod, sCode, sMsg, sContent, sSend: string;
      vJs, tJs: ISuperObject;
    begin
      sCode:= '9001';
      sMsg:= 'Unknown error';
      sMethod:= 'heart';
      systemLog(request.DataString);
      try
        sContent:= GetParam(request, 'content');
        systemLog(sContent);
        sCode:= '9000';
        sMsg:= 'Success';
      finally
        tJs:= TSuperObject.Create;
        tJs.S['code']:= sCode;
        tJs.S['message']:= sMsg;
        tJs.S['method']:= sMethod;
        tJs.S['servertime']:= FormatDateTime('YYYY-MM-DD hh:mm:ss', Now);
        sSend:= tJs.AsString;
        _HttpSend(response, sSend);
      end;
    end;
    
    class function THttpEvent._HttpSend(response: TIocpHttpResponse;
      sSend: string): Boolean;
    var
      O: TIocpHttpWriter;
    begin
      O:= response.GetOutWriter();
      O.Charset:= hct_UTF8;
      O.Write(sSend);
      O.Flush;
    end;
    
    end.

    5. uServer.pas内容如下

        服务的核心类,处理http请求的响应。

    unit uServer;
    
    interface
    
    uses
      iocp, iocp.Http, iocp.Utils.Hash, SysUtils, Classes, iocp.Http.WebSocket;
    
    type
      PMethod = ^TMethod;
    
      TOnProcRequest= function(Request: TIocpHttpRequest; Response: TIocpHttpResponse): Boolean of object;
      TOnRecvBuffer= procedure(const pvClientContext: TIocpContext; buf: Pointer; len: Cardinal; errCode: integer) of object;
      TOnAccept= procedure(pvSocket: THandle; const pvAddr: string; pvPort: Word; var vAllowAccept: Boolean) of object;
      TOnDisAccept= procedure(const Context: TIocpContext) of object;
    
      TCenterServer= class(TObject)
      private
        FWebService: TIocpHttpServer;
        FProcList: TStringHash;
      protected
        function isDestroying: Boolean;
        procedure doRequest(Sender: TIocpHttpServer; request: TIocpHttpRequest; response: TIocpHttpResponse);
        procedure doWebSocketRequest(Sender: TIocpWebSocketServer; request: TIocpWebSocketRequest; response: TIocpWebSocketResponse);
        procedure doFreeProcItem(item: PHashItem);
      public
        FStickRef: Integer;
        constructor Create(httpPort: Word); reintroduce;
        destructor Destroy; override;
        procedure RegHttpProc(const URI: string; const Proc: TOnProcRequest);
        procedure RegSocketProc(const OnRecvBuffer: TOnRecvBuffer; const onAccept: TOnAccept; const onDisAccept: TOnDisAccept);
        procedure Start;
        procedure Stop;
      end;
    
    var
      GURL: string;
    
    implementation
    
    uses uPublic;
    
    { TCenterServer }
    
    constructor TCenterServer.Create(httpPort: Word);
    begin
      FWebService:= TIocpHttpServer.Create(nil);
      FWebService.ListenPort:= httpPort;
      FWebService.UploadMaxDataSize:= 1024* 1024;
      FWebService.MaxTaskWorker:= 64;
      FWebService.MaxContextPoolSize:= 1;
      FWebService.OnHttpRequest:= doRequest;
    
      FProcList:= TStringHash.Create();
      FProcList.OnFreeItem:= doFreeProcItem;
    end;
    
    destructor TCenterServer.Destroy;
    begin
      try
        Stop;
        if Assigned(FWebService) then
          FreeAndNil(FWebService);
        if Assigned(FProcList) then
          FreeAndNil(FProcList);
      except
    
      end;
      inherited;
    end;
    
    procedure TCenterServer.doFreeProcItem(item: PHashItem);
    begin
      if item<> nil then
        Dispose(Pointer(item.Value));
    end;
    
    procedure TCenterServer.doRequest(Sender: TIocpHttpServer;
      request: TIocpHttpRequest; response: TIocpHttpResponse);
    var
      sMethod: string;
      index: Number;
    begin
      if request.URI<> GURL then
      begin
        response.ErrorRequest(404);
        Exit;
      end;
      sMethod:= getParam(request, 'method');
      index:= FProcList.ValueOf(LowerCase(string(sMethod)));
      if index<> -1 then
      begin
        TOnProcRequest(PMethod(Pointer(index))^)(request, response);
      end
      else
      begin
        response.ErrorRequest(404);
      end;
    end;
    
    procedure TCenterServer.doWebSocketRequest(Sender: TIocpWebSocketServer;
      request: TIocpWebSocketRequest; response: TIocpWebSocketResponse);
    var
      S: TMemoryStream;
      Data: string;
    begin
      S:= TMemoryStream.Create;
      try
        Data:= request.DataString(hct_UTF8);
        S.Write(Data[1], Length(Data) {$IFDEF UNICODE} sh1 1 {$ENDIF});
        S.Position:= 0;
        response.Send(S, wso_Text);
      finally
        S.Free;
      end;
      response.Send(request.DataString());
    end;
    
    function TCenterServer.isDestroying: Boolean;
    begin
      Result:= (not Assigned(Self));
    end;
    
    procedure TCenterServer.RegHttpProc(const URI: string;
      const Proc: TOnProcRequest);
    var
      P: PMethod;
    begin
      if Length(URI)= 0 then
        Exit;
      if Assigned(Proc) then
      begin
        New(P);
        P^:= TMethod(Proc);
        FProcList.Add(LowerCase(URI), Integer(P));
      end;
    end;
    
    procedure TCenterServer.RegSocketProc(const OnRecvBuffer: TOnRecvBuffer;
      const onAccept: TOnAccept; const onDisAccept: TOnDisAccept);
    begin
      //
    end;
    
    procedure TCenterServer.Start;
    begin
      FWebService.Open;
    end;
    
    procedure TCenterServer.Stop;
    begin
      FWebService.Close;
    end;
    
    end.

    6. uVar.pas内容如下

    unit uVar;
    
    interface
    
    uses
      SysUtils, Forms, IniFiles;
    
    type
      TAppParam= class
      public
        class function AppPath: string;   // 路径
        class function AppName: string;   // 程序名
        class function AppVer: string;    // 版本
      end;
    
      TFilePath= class(TAppParam)
      public
        class function IniFile: string;
      end;
    
      //运行参数
      TRunParam = record
        iHttpPort  : Integer;
      end;
    
      TAppRunClass = class
      private
        FRunParam : TRunParam;                       //运行参数 从ini文件或数据库中读取
      public
        constructor Create;
        destructor Destroy; override;
        //读取基础数据
        function ReadPara : Boolean;               //读取基础参数
      published
        property RunPara : TRunParam read FRunParam write FRunParam ;
      end;
    
    var
      GAppRunClass: TAppRunClass;
    
    implementation
    
    { TAppParam }
    
    class function TAppParam.AppName: string;
    begin
      Result := ExtractFileName(Application.ExeName);
    end;
    
    class function TAppParam.AppPath: string;
    begin
      Result := ExtractFilePath(ParamStr(0));
    end;
    
    class function TAppParam.AppVer: string;
    begin
      //
    end;
    
    { TFilePath }
    
    class function TFilePath.IniFile: string;
    begin
      Result := AppPath + 'Server.ini';
    end;
    
    { TAppRunClass }
    
    constructor TAppRunClass.Create;
    begin
      //
    end;
    
    destructor TAppRunClass.Destroy;
    begin
    
      inherited;
    end;
    
    function TAppRunClass.ReadPara: Boolean;
    var
      sFile : string;
      sIni : TIniFile;
    begin
      Result := False;
      sFile := TFilePath.IniFile;
      if FileExists(sFile) then
      begin
        sIni := TIniFile.Create(sFile);
        try
          FRunParam.iHttpPort     := sIni.ReadInteger('SYSTEM', 'iHttpPort', 5000);
          Result := True;
        finally
          FreeAndNil(sIni);
        end;
      end;
    end;
    
    end.

    7. uFrmMain.pas窗体如下

        窗体的create里写了服务的启动,供调试使用。(Release下是不会创建该窗体的)

    unit uFrmMain;
    
    interface
    
    uses
      Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
      Dialogs, uServer;
    
    type
      TfrmMain = class(TForm)
        procedure FormCreate(Sender: TObject);
        procedure FormDestroy(Sender: TObject);
      private
        { Private declarations }
        FServer: TCenterServer;
      public
        //
      end;
    
    var
      frmMain: TfrmMain;
    
    implementation
    
    uses uHttpEvent, uPublic, uVar;
    
    {$R *.dfm}
    
    procedure TfrmMain.FormCreate(Sender: TObject);
    begin
      FServer:= TCenterServer.Create(GAppRunClass.RunPara.iHttpPort);
      FServer.RegHttpProc('cwx.heart', THttpEvent._Heart);
      FServer.RegHttpProc('cwx.servertime', THttpEvent._GetServerTime);
      GURL:= '/gateway.do';
      FServer.Start;
      SystemLog('FServer.Started');
    end;
    
    procedure TfrmMain.FormDestroy(Sender: TObject);
    begin
      if Assigned(FServer) then
        FreeAndNil(FServer);
    end;
    
    end.

    8. uAppFactory.pas内容如下

    unit uAppFactory;
    
    interface
    
    uses
      SysUtils, Forms, Windows, DateUtils, uServer;
    
    type
      TAppFactory= class
      private
        FServer: TCenterServer;
      protected
        function CreateMainForm(var sErr: string): Boolean; virtual;
      public
        constructor Create; virtual;
        destructor Destroy; override;
        function StartServer: Boolean;
        procedure StopServer;
        function Factory(var sErr: string): Boolean; virtual;
      end;
    
    implementation
    
    uses uVar, uFrmMain, uPublic, uHttpEvent;
    
    { TAppFactory }
    
    constructor TAppFactory.Create;
    var
      sPath: string;
      dDateTime: TDateTime;
    begin
      GAppRunClass:= TAppRunClass.Create;
    end;
    
    function TAppFactory.CreateMainForm(var sErr: string): Boolean;
    begin
      Result:= False;
      try
        if not Assigned(frmMain) then
          Application.CreateForm(TfrmMain, frmMain);
        Result:= True;
      except
        on e: Exception do
        begin
          sErr:= 'Err:创建主窗体失败 '+ e.message;
        end;
      end;
    end;
    
    destructor TAppFactory.Destroy;
    begin
      StopServer;
      if Assigned(frmMain) then
        frmMain.Destroy;
      if Assigned(GAppRunClass) then
        FreeAndNil(GAppRunClass);
      inherited;
    end;
    
    function TAppFactory.Factory(var sErr: string): Boolean;
    begin
      Result:= False;
      while not Result do
      begin
        ProcessMessage;
        if not GAppRunClass.ReadPara then
        begin
          sErr:= '系统参数读取错误, 系统无法正常启动!';
          systemLog(sErr);
          Sleep(5000);
          Continue;
        end;
        {$IFDEF RELEASE}
        if not StartServer then
        begin
          sErr:= '系统参数读取错误, 系统无法正常启动!';
          systemLog(sErr);
          Sleep(5000);
          Continue;
        end;
        {$ENDIF}
        Result:= True;
      end;
    end;
    
    function TAppFactory.StartServer: Boolean;
    begin
      Result:= False;
      if Assigned(FServer) then
      begin
        Result:= True;
        Exit;
      end;
      //注册方法
      FServer:= TCenterServer.Create(GAppRunClass.RunPara.iHttpPort);
      FServer.RegHttpProc('cwx.heart', THttpEvent._Heart);
      FServer.RegHttpProc('cwx.servertime', THttpEvent._GetServerTime);
      GURL:= '/gateway.do';
      FServer.Start;
      SystemLog('FServer.Started');
      result:= True;
    end;
    
    procedure TAppFactory.StopServer;
    begin
      if Assigned(FServer) then
        FreeAndNil(FServer);
    end;
    
    end.

    服务安装:

     

    可以通过cmd命令来进行安装,也可以写程序进行安装。

    新建工程, 工程文件保存为InstallService, Unit1.pas保存为uFrmMain.pas.

     

    1. 工程文件InstallService内容如下

    program InstallService;
    
    uses
      Forms,
      uFrmMain in 'uFrmMain.pas' {FrmMain};
    
    {$R *.res}
    
    begin
      Application.Initialize;
      Application.MainFormOnTaskbar := True;
      Application.CreateForm(TFrmMain, FrmMain);
      Application.Run;
    end.

    2. uFrmMain.pas内容如下

        注意以下InstallService方法的第一个参数和服务uService那里的Name属性要一致。

    unit uFrmMain;
    
    interface
    
    uses
      Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
      Dialogs, StdCtrls,SvcMgr,winsvc,Registry;
    
    type
      TFrmMain = class(TForm)
        memo1: TMemo;
        btn1: TButton;
        btn2: TButton;
        procedure btn1Click(Sender: TObject);
        procedure btn2Click(Sender: TObject);
      private
        { Private declarations }
      public
        { Public declarations }
         function InstallService(ServiceName, DisplayName, FileName: string): boolean;
         function UninstallService(ServiceName: string):boolean;
         function UpdateDes(name,des :string):Boolean;
      end;
    var
      FrmMain: TFrmMain;
    
    implementation
        uses ShellAPI;
    {$R *.dfm}
    
    { TForm21 }
    
    procedure TFrmMain.btn1Click(Sender: TObject);
    begin
      memo1.Clear;
      if UninstallService('CenterService') then
        memo1.Lines.Add('服务卸载成功')
      else
        memo1.Lines.Add('服务卸载失败');
      Memo1.Lines.Add('如果卸载服务时有返回-1,则多试几次,或强制结束进程再卸载。');
    end;
    
    procedure TFrmMain.btn2Click(Sender: TObject);
    var
     fnamePath,ServiceName :string;
    begin
      memo1.Clear;
      SetCurrentDir(ExtractFilePath(Forms.Application.exename));
      SetCurrentDir(GetCurrentDir);
      fnamePath :=  GetCurrentDir +'\ControlCenter.exe';
      if not FileExists(fnamePath) then
      begin
        memo1.Lines.Add('error: ControlCenter.exe');
        Exit;
      end;
      if InstallService('CenterService','CWX服务',fnamePath) then
      begin
        memo1.Lines.Add('服务安装成功');
        UpdateDes('CenterService','CWX服务');
      end
      else
        memo1.Lines.Add('服务安装失败');
    end;
    
    function TFrmMain.InstallService(ServiceName, DisplayName,
      FileName: string): boolean;
    var
      SCManager,Service: THandle;
      Args: pchar;
      str :string;
    begin
      Result := False;
      SCManager := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
      if SCManager = 0 then Exit;
      try
       Service := CreateService(SCManager,  //句柄
                        PChar(ServiceName), //服务名称
                        PChar(DisplayName), //显示服务名
                        SERVICE_ALL_ACCESS, //服务访问类型
                        SERVICE_WIN32_OWN_PROCESS or SERVICE_INTERACTIVE_PROCESS, //服务类型  or SERVICE_WIN32_OWN_PROCESS,//
                        SERVICE_AUTO_START, //自动启动服务
                        SERVICE_ERROR_IGNORE, //忽略错误
                        PChar(FileName),  //启动的文件名
                        nil,  //name of load ordering group (载入组名) &#39;LocalSystem&#39;
                        nil,  //标签标识符
                        nil,  //相关性数组名
                        nil,  //帐户(当前)
                        nil); //密码(当前)
    
        Args := nil;
        if Service = 0 then exit;
        if StartService(Service, 0, Args) then
          memo1.Lines.Add(DisplayName+' 服务已经启动')
        else
          memo1.Lines.Add(DisplayName+' 服务启动失败!');
        CloseServiceHandle(Service);
        CloseServiceHandle(SCManager);
      except on E: Exception do
        begin
          CloseServiceHandle(SCManager);
          Memo1.Lines.Add('失败原因是:' + E.Message);
        end;
      end;
      Result := True;
    end;
    
    function TFrmMain.UninstallService(ServiceName: string): boolean;
    var
      SCManager,Service: THandle;
      ServiceStatus: SERVICE_STATUS;
      ss: LongBool;
    begin
      Result:=false;
      SCManager := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);//获得SC管理器句柄
      if SCManager = 0 then Exit;
      try
        Service := OpenService(SCManager, PChar(ServiceName), SERVICE_ALL_ACCESS);
    
        //以最高权限打开指定服务名的服务,并返回句柄
        ss := ControlService(Service, SERVICE_CONTROL_STOP, ServiceStatus);
        Memo1.Lines.Add('停止服务结果:' + BoolToStr(ss));
    
        //向服务器发送控制命令,停止工作, ServiceStatus 保存服务的状态
        ss := DeleteService(Service);
        Memo1.Lines.Add('卸载服务结果:' + BoolToStr(ss));
        //从SC ManGer 中删除服务
        CloseServiceHandle(Service);
        result:=true;
        //关闭句柄,释放资源
      finally
        CloseServiceHandle(SCManager);
      end;
    end;
    
    function TFrmMain.UpdateDes(name, des: string): Boolean;
    var
      reg: TRegistry;
    begin 
      reg := TRegistry.Create; 
      try
        with reg do begin 
          RootKey := HKEY_LOCAL_MACHINE; 
          if OpenKey('SYSTEM\CurrentControlSet\Services\'+Name,false) then
          begin 
            WriteString('Description',des); 
          end; 
          CloseKey; 
        end; 
      finally 
        reg.Free; 
      end; 
    end;
    
    end.

    终端:

     

    在服务安装成功的情况下,通过终端可以向服务发出请求。

    新建工程, 工程文件保存为ClientDemo, Unit1.pas保存为uFrmMain.pas.

    新建配置文件Client.ini, 添加如下

    [SYSTEM]
    url=http://服务IP地址:服务开放端口/gateway.do

     

    1. 工程文件ClientDemo内容如下

    program ClientDemo;
    
    uses
      Forms,
      uFrmMain in 'uFrmMain.pas' {Form21},
      uVar in 'uVar.pas';
    
    {$R *.res}
    
    begin
      Application.Initialize;
      Application.MainFormOnTaskbar := True;
      Application.CreateForm(TForm21, Form21);
      Application.Run;
    end.

    2. uFrmMain.pas内容如下

       

    unit uFrmMain;
    
    interface
    
    uses
      Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
      Dialogs, StdCtrls, Mask, RzEdit, RzLabel, ExtCtrls,ActnList,uVar;
    
    type
      TForm21 = class(TForm)
        btnHeart: TButton;
        btnServerTime: TButton;
        Memo1: TMemo;
        procedure FormCreate(Sender: TObject);
        procedure FormDestroy(Sender: TObject);
        procedure btnHeartClick(Sender: TObject);
        procedure btnServerTimeClick(Sender: TObject);
      private
        { Private declarations }
      public
        { Public declarations }
      end;
    
    var
      Form21: TForm21;
    
    implementation
    
    uses superobject;
    
    {$R *.dfm}
    
    procedure TForm21.btnHeartClick(Sender: TObject);
    var
      Vjson: ISuperObject;
      sOut: string;
    begin
      Vjson := SO();
      try
        Vjson.S['poscode'] := '35';
        if not GAppRunClass.Info_POSt(sOut, 'cwx.heart', Vjson.AsString) then
        begin
          Memo1.Lines.Add(sOut);
          Exit;
        end;
        try
          Memo1.Lines.Add(sOut);
        except
    
        end;
      finally
        Vjson := nil;
      end;
    end;
    
    procedure TForm21.btnServerTimeClick(Sender: TObject);
    var
      Vjson: ISuperObject;
      sOut: string;
    begin
      Vjson := SO();
      try
        Vjson.S['poscode'] := '35';
        if not GAppRunClass.Info_POSt(sOut, 'cwx.servertime', Vjson.AsString) then
        begin
          Memo1.Lines.Add(sOut);
          Exit;
        end;
        try
          Memo1.Lines.Add(sOut);
        except
    
        end;
      finally
        Vjson := nil;
      end;
    end;
    
    procedure TForm21.FormCreate(Sender: TObject);
    begin
      GAppRunClass := TAppRunClass.Create;
      GAppRunClass.ReadPara;
    end;
    
    procedure TForm21.FormDestroy(Sender: TObject);
    begin
      if Assigned(GAppRunClass) then
        FreeAndNil(GAppRunClass);
    end;
    
    end.

    3. uVar.pas内容如下

    unit uVar;
    
    interface
    
    uses
      SysUtils,IniFiles,Forms,IdHTTP,superobject,CnSHA1,Classes;
    
    type
      TRunPara = record
        url :string;
      end;
    
      TAppRunClass = class
      private
        FRunPara : TRunPara;
      published
        property RunPara : TRunPara read FRunPara write FRunPara ;
      public
        function ReadPara : Boolean;
        function Info_POSt(var sOut: string; smethod, content: string): Boolean;
        constructor Create;
        destructor Destroy; override;
      end;
    
    var
      GAppRunClass : TAppRunClass;
    
    implementation
    
    { TAppRunClass }
    
    constructor TAppRunClass.Create;
    begin
    
    end;
    
    destructor TAppRunClass.Destroy;
    begin
    
      inherited;
    end;
    
    
      
    function TAppRunClass.Info_POSt(var sOut: string; smethod, content: string): Boolean;
    var
      sSend, str: string;
      lSend: TStringList;
      fidhttp: Tidhttp;
    begin
      fidhttp := Tidhttp.Create(nil);
      try
        fidhttp.Request.ContentType := 'application/x-www-form-urlencoded';
        fidhttp.ReadTimeout := 5000;
        fidhttp.ConnectTimeout := 5000;
    
        Result := False;
        lSend := TStringList.Create;
        try
          str := 'method=' + smethod;
          lSend.Add(UTF8Encode(str));
          str := 'charset=' + 'utf-8';
          lSend.Add(UTF8Encode(str));
          str := 'timestamp=' + FormatDateTime('yyyy-MM-dd HH:mm:ss', Now);
          lSend.Add(UTF8Encode(str));
          str := 'content=' + content;
          lSend.Add(UTF8Encode(str));
          try
            sOut := fidhttp.Post(GAppRunClass.RunPara.url, lSend);
            sOut := UTF8Decode(sOut);
            Result := True;
          except
            on e: Exception do
            begin
              sOut:= e.Message;
            end;
          end;
        finally
          FreeAndNil(lSend);
        end;
      finally
        FreeAndNil(fidhttp);
      end;
    end;
    
    function TAppRunClass.ReadPara: Boolean;
    var
      sFile : string;
      sIni : TIniFile;
    begin
      Result := False;
      sFile :=   ExtractFilePath(Application.ExeName) + 'Client.ini';
      if FileExists(sFile) then
      begin
        sIni := TIniFile.Create(sFile);
        try
          FRunPara.url := sIni.ReadString('SYSTEM','url','');
          Result := True;
        finally
          FreeAndNil(sIni);
        end;
      end;
    end;
    
    end.

    测试:

     

    1. 编译服务 Release版本, 编译服务安装程序 , 编译终端程序

        将三个程序和Server.ini、Client.ini都放在一个目录下。如下图所示

    2. 安装服务端,右击InstallService.exe, 以管理员身份运行, 点击安装服务:

        控制面板-> 管理工具-> 服务

        cmd命令下输入regedit, 在HKEY_LOCAL_MACHINE-> SYSTEM-> CurrentControlSet-> Services下可以找到

    3. 终端调用

        运行多个ClientDemo.exe, 进行调用

     

     

    结束!

    展开全文
  • 这里我看的顺序是TChannel,然后是TService。然后发现个人感觉先看TService好理解点 现在不用管TChannel到底干什么了,只用先看个流程 AService是TService基类,主要的函数就是下面几个,可以发现在接收和读取时...

    这里我看的顺序是TChannel,然后是TService。然后发现个人感觉先看TService好理解点
    现在不用管TChannel到底干什么了,只用先看个流程


    AService是TService基类,主要的函数就是下面几个,可以发现在接收和读取时调用的委托


    下面来看TService的异步接收


    接收完后,重新执行AcceptAsync,并根据socket创建TChannel并存储在idChannels中
    最后执行OnAccept,由AService可以知道这个就是一个委托


    并且TService还具有代替TChannel发送的功能和执行TChannel的Update功能


    展开全文
  • TService和KService学习笔记 请大家关注我的微博:@NormanLin_BadPixel坏像素 这里我默认大家已经了解TCP跟UDP咯。如果真有不了解的,这里提供一个传送门学习,保证学会。 因为3.0更新后把UDP变为KCP了,这里给...
  • 研究delphi服务的路径,试了好几个方法 ,都没取出来,最后发现,要采用取DLL路径的方法//一、获取Dll自身路径//1)方法一:Function GetDllPath(sDllName:string):string;varModuleFileName:array[0..255] of char;...
  • elphi的TService的輸入桌面切換 dfm:object CopyDeskService: TCopyDeskService OldCreateOrder = False OnCreate = ServiceCreate OnDestroy = ServiceDestroy AllowPause = False DisplayName = Copy Desk ...
  • 用 Delphi(6),写的一个 TService。 比如在 Start 中。 procedure TXXX.ServiceStart(Sender: TService; var Started: Boolean); var ov:OleVariant; iErr:Integer; begin CoInitialize(nil); try ...
  •  public static IServiceCollection AddTransient<TService, TImplementation>(this IServiceCollection services)  where TService : class  where TImplementation : class, TService  {  if ...
  • ServiceDescriptor Singleton<TService>(Func, TService> implementationFactory) where TService: class ; public static ServiceDescriptor Singleton<TService>(TService implementationInstance) ...
  • procedure ServiceContinue(Sender: TService; var Continued: Boolean); procedure ServiceExecute(Sender: TService); procedure ServicePause(Sender: TService; var Paused: Boolean); procedure ...
  • 用 Delphi 创建服务程序(Service)

    千次阅读 2016-08-29 09:11:13
    procedure TDelphiService.ServiceShutdown(Sender: TService); begin  gbCanClose := true;  FrmMain.Free;  Status := csStopped;   ReportStatus(); end;   procedure ...
  • procedure TDelphiService.ServiceShutdown(Sender: TService); begin gbCanClose := true; FrmMain.Free; Status := csStopped; ReportStatus(); end; procedure TDelphiService.ServiceStart(Sender: ...
  • 用Delphi创建windows服务程序

    千次阅读 2018-11-08 02:23:14
    procedure TDelphiService.ServiceContinue(Sender: TService; var Continued: Boolean); begin while not Terminated do begin Sleep(10); ServiceThread.ProcessRequests(False); end; end; procedure ...

空空如也

空空如也

1 2 3 4 5 ... 20
收藏数 1,382
精华内容 552
关键字:

TService