论坛广场 › Delphi › ADO 存取数据库时的分页显示详

阿杰 发表于 2010-7-3 18:53:32

ADO 存取数据库时的分页显示详

Delphi编写系统服务一：如何编写一个系统服务
打开Delphi编辑器，选择菜单中的File|New|Other...，在New Item中选择Service Application项，Delphi便自动为你建立一个基于TServiceApplication的新工程，TserviceApplication是一个封装NT服务程序的类，它包含一个TService1对象以及服务程序的装卸、注册、取消方法。
TService属性介绍：
AllowPause：是否允许暂停；
AllowStop：是否允许停止；
Dependencies：启动服务时所依赖的服务，如果依赖服务不存在则不能启动服务，而且启动本服务的时候会自动启动依赖服务；
DisplayName：服务显示名称；
ErrorSeverity：错误严重程度；
Interactive：是否允许和桌面交互；
LoadGroup：加载组；
Name：服务名称；
Password：服务密码；
ServiceStartName：服务启动名称；
ServiceType：服务类型；
StartType：启动类型；
事件介绍：
AfterInstall：安装服务之后调用的方法；
AfterUninstall：服务卸载之后调用的方法；
BeforeInstall：服务安装之前调用的方法；
BeforeUninstall：服务卸载之前调用的方法；
OnContinue：服务暂停继续调用的方法；
OnExecute：执行服务开始调用的方法；
OnPause：暂停服务调用的方法；
OnShutDown：关闭时调用的方法；
OnStart：启动服务调用的方法；
OnStop：停止服务调用的方法；

阿杰 发表于 2010-7-3 18:53:41

Delphi编写系统服务二：系统服务和桌面程序的区别

Windows 2000/XP/2003等支持一种叫做“系统服务程序”的进程，系统服务和桌面程序的区别是：
系统服务不用登陆系统即可运行；
系统服务是运行在System Idle Process/System/smss/winlogon/services下的，而桌面程序是运行在Explorer下的；
系统服务拥有更高的权限，系统服务拥有Sytem的权限，而桌面程序只有Administrator权限；
在Delphi中系统服务是对桌面程序进行了再一次的封装，既系统服务继承于桌面程序。因而拥有桌面程序所拥有的特性；
系统服务对桌面程序的DoHandleException做了改进，会自动把异常信息写到NT服务日志中；
普通应用程序启动只有一个线程，而服务启动至少含有三个线程。（服务含有三个线程：TServiceStartThread服务启动线程；TServiceThread服务运行线程；Application主线程，负责消息循环）；
摘录代码：
procedure TServiceApplication.Run;
begin
    .
    .
    .
      StartThread := TServiceStartThread.Create(ServiceStartTable);
      try
      while not Forms.Application.Terminated do
          Forms.Application.HandleMessage;
      Forms.Application.Terminate;
      if StartThread.ReturnValue <> 0 then
          FEventLogger.LogMessage(SysErrorMessage(StartThread.ReturnValue));
      finally
      StartThread.Free;
      end;
   .
   .
   .
end;

procedure TService.DoStart;
begin
    try
      Status := csStartPending;
      try
      FServiceThread := TServiceThread.Create(Self);
      FServiceThread.Resume;
      FServiceThread.WaitFor;
      FreeAndNil(FServiceThread);
      finally
      Status := csStopped;
      end;
    except
      on E: Exception do
      LogMessage(Format(SServiceFailed,));
    end;
end;
在系统服务中也可以使用TTimer这些需要消息的定时器，因为系统服务在后台使用TApplication在分发消息；

阿杰 发表于 2010-7-3 18:54:05

Delphi编写系统服务三：编写两栖系统服务

采用下面的方法，可以实现一个两栖系统服务（既系统服务和桌面程序的两种模式）
工程代码：
program FleetReportSvr;

uses
SvcMgr,
Forms,
SysUtils,
Windows,
SvrMain in 'SvrMain.pas' {FleetReportService: TService},
AppMain in 'AppMain.pas' {FmFleetReport}；

{$R *.RES}

const
CSMutexName = 'Global\Services_Application_Mutex';
var
OneInstanceMutex: THandle;
SecMem: SECURITY_ATTRIBUTES;
aSD: SECURITY_DESCRIPTOR;
begin
InitializeSecurityDescriptor(@aSD, SECURITY_DESCRIPTOR_REVISION);
SetSecurityDescriptorDacl(@aSD, True, nil, False);
SecMem.nLength := SizeOf(SECURITY_ATTRIBUTES);
SecMem.lpSecurityDescriptor := @aSD;
SecMem.bInheritHandle := False;
OneInstanceMutex := CreateMutex(@SecMem, False, CSMutexName);
if (GetLastError = ERROR_ALREADY_EXISTS)then
begin
    DlgError('Error, Program or service already running!');
    Exit;
end;
if FindCmdLineSwitch('svc', True) or
    FindCmdLineSwitch('install', True) or
    FindCmdLineSwitch('uninstall', True) then
begin
    SvcMgr.Application.Initialize;
    SvcMgr.Application.CreateForm(TSvSvrMain, SvSvrMain);
    SvcMgr.Application.Run;
end
else
begin
    Forms.Application.Initialize;
    Forms.Application.CreateForm(TFmFmMain, FmMain);
    Forms.Application.Run;
end;
end.
然后在SvrMain注册服务：
unit SvrMain;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs, MsgCenter;

type
TSvSvrMain = class(TService)
    procedure ServiceStart(Sender: TService; var Started: Boolean);
    procedure ServiceStop(Sender: TService; var Stopped: Boolean);
    procedure ServiceBeforeInstall(Sender: TService);
    procedure ServiceAfterInstall(Sender: TService);
private
    { Private declarations }
public
    function GetServiceController: TServiceController; override;
    { Public declarations }
end;

var
SvSvrMain: TSvSvrMain;

implementation

const
CSRegServiceURL = 'SYSTEM\CurrentControlSet\Services\';
CSRegDescription = 'Description';
CSRegImagePath = 'ImagePath';
CSServiceDescription = 'Services Sample.';

{$R *.DFM}

procedure ServiceController(CtrlCode: DWord); stdcall;
begin
SvSvrMain.Controller(CtrlCode);
end;

function TSvSvrMain.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;

procedure TSvSvrMain.ServiceStart(Sender: TService;
var Started: Boolean);
begin
Started := dmPublic.Start;
end;

procedure TSvSvrMain.ServiceStop(Sender: TService;
var Stopped: Boolean);
begin
Stopped := dmPublic.Stop;
end;

procedure TSvSvrMain.ServiceBeforeInstall(Sender: TService);
begin
RegValueDelete(HKEY_LOCAL_MACHINE, CSRegServiceURL + Name, CSRegDescription);
end;

procedure TSvSvrMain.ServiceAfterInstall(Sender: TService);
begin
RegWriteString(HKEY_LOCAL_MACHINE, CSRegServiceURL + Name, CSRegDescription,
    CSServiceDescription);
RegWriteString(HKEY_LOCAL_MACHINE, CSRegServiceURL + Name, CSRegImagePath,
    ParamStr(0) + ' -svc');
end;

end.
这样，双击程序，则以普通程序方式运行，若用服务管理器来运行，则作为服务运行。
例如公共模块：
dmPublic，提供Start,Stop方法。

在主窗体中，调用dmPublic.Start，dmPublic.Stop方法。
同样在Service中，调用dmPublic.Start，dmPublic.Stop方法。

阿杰 发表于 2010-7-3 18:54:58

Delphi编写系统服务四：如何限制系统服务和桌面程序只运行一个

如何限制系统服务和桌面程序只运行一个

在工程加入下列代码可以设置系统服务和桌面程序只运行一个。
program FleetReportSvr;

uses
SvcMgr,
Forms,
SysUtils,
Windows,
SvrMain in 'SvrMain.pas' {FleetReportService: TService},
AppMain in 'AppMain.pas' {FmFleetReport}；

{$R *.RES}

const
CSMutexName = 'Global\Services_Application_Mutex';
var
OneInstanceMutex: THandle;
SecMem: SECURITY_ATTRIBUTES;
aSD: SECURITY_DESCRIPTOR;
begin
InitializeSecurityDescriptor(@aSD, SECURITY_DESCRIPTOR_REVISION);
SetSecurityDescriptorDacl(@aSD, True, nil, False);
SecMem.nLength := SizeOf(SECURITY_ATTRIBUTES);
SecMem.lpSecurityDescriptor := @aSD;
SecMem.bInheritHandle := False;
OneInstanceMutex := CreateMutex(@SecMem, False, CSMutexName);
if (GetLastError = ERROR_ALREADY_EXISTS)then
begin
    DlgError('Error, Program or service already running!');
    Exit;
end;
if FindCmdLineSwitch('svc', True) or
    FindCmdLineSwitch('install', True) or
    FindCmdLineSwitch('uninstall', True) then
begin
    SvcMgr.Application.Initialize;
    SvcMgr.Application.CreateForm(TSvSvrMain, SvSvrMain);
    SvcMgr.Application.Run;
end
else
begin
    Forms.Application.Initialize;
    Forms.Application.CreateForm(TFmFmMain, FmMain);
    Forms.Application.Run;
end;
end.

阿杰 发表于 2010-7-3 18:55:25

Delphi编写系统服务五：在系统服务和桌面程序之间共享内存

用于创建内核对象的函数几乎都有一个指向SECURITY_ATTRIBUTES结构的指针作为其参数，在使用CreateFileMapping函数的时候，通常只是为该参数传递NULL，这样就可以创建带有默认安全性的内核对象。   
    默认安全性意味着对象的管理小组的任何成员和对象的创建者都拥有对该对象的全部访问权，而其他所有人均无权访问该对象。可以指定一个ECURITY_ATTRIBUTES结构，对它进行初始化，并为该参数传递该结构的地址。   
   它包含的与安全性有关的成员实际上只有一个，即lpSecurityDescriptor。当你想要获得对相应的一个内核对象的访问权（而不是创建一个新对象）时，必须设定要对该对象执行什么操作。如果想要访问一个现有的文件映射内核对象，以便读取它的数据，那么调用OpenfileMapping函数：通过将FILE_MAP_READ作为第一个参数传递给OpenFileMapping，指明打算在获得对该文件映象的访问权后读取该文件，   该函数在返回一个有效的句柄值之前，首先   
   执行一次安全检查。如果（已登录用户）被允许访问现有的文件映射内核对象，就返回一个有效的句柄。但是，如果被拒绝访问该对象，将返回NULL。

系统服务端核心代码：

constructor TPublicVars.Create(ANew: Boolean);
var
SecMem: SECURITY_ATTRIBUTES;
aSD: SECURITY_DESCRIPTOR;
begin
inherited Create;
{ 创建一个任何用户都可以访问的内核对象访问权 }
InitializeSecurityDescriptor(@aSD, SECURITY_DESCRIPTOR_REVISION);
SetSecurityDescriptorDacl(@aSD, True, nil, False);
SecMem.nLength := SizeOf(SECURITY_ATTRIBUTES);
SecMem.lpSecurityDescriptor := @aSD;
SecMem.bInheritHandle := False;
FMapFile := CreateFileMapping($FFFFFFFF, @SecMem, PAGE_READWRITE, 0, CSharedMemSize, CSharedMemName);
FMapFile := OpenFileMapping(File_Map_All_Access, False, CSharedMemName);
if (FMapFile = 0) then
begin
    raise Exception.Create(SysErrorMessage(GetLastError));
    OutputDebugString(PChar(SysErrorMessage(GetLastError)));
end
else
begin                                 // 成功
    FShareMem := MapViewOfFile(FMapFile, File_Map_All_Access, 0, 0, CSharedMemSize);
    OutputDebugString(PChar(SysErrorMessage(GetLastError) + ',Handle=' + IntToStr(Handle)));
end;
end;

destructor TPublicVars.Destroy;
begin
UnmapViewOfFile(FShareMem);
CloseHandle(FMapFile);
inherited;
end;

桌面程序核心源代码：

constructor TPublicVars.Create(ANew: Boolean);
var
SecMem: SECURITY_ATTRIBUTES;
aSD: SECURITY_DESCRIPTOR;
begin
inherited Create;
{ 创建一个任何用户都可以访问的内核对象访问权 }
InitializeSecurityDescriptor(@aSD, SECURITY_DESCRIPTOR_REVISION);
SetSecurityDescriptorDacl(@aSD, True, nil, False);
SecMem.nLength := SizeOf(SECURITY_ATTRIBUTES);
SecMem.lpSecurityDescriptor := @aSD;
SecMem.bInheritHandle := False;
FMapFile := CreateFileMapping($FFFFFFFF, @SecMem, PAGE_READWRITE, 0, CSharedMemSize, CSharedMemName);
FMapFile := OpenFileMapping(File_Map_All_Access, False, CSharedMemName);
if (FMapFile = 0) then
begin
    raise Exception.Create(SysErrorMessage(GetLastError));
    OutputDebugString(PChar(SysErrorMessage(GetLastError)));
end
else
begin                                 // 成功
    FShareMem := MapViewOfFile(FMapFile, File_Map_All_Access, 0, 0, CSharedMemSize);
    OutputDebugString(PChar(SysErrorMessage(GetLastError) + ',Handle=' + IntToStr(Handle)));
end;
end;

destructor TPublicVars.Destroy;
begin
UnmapViewOfFile(FShareMem);
CloseHandle(FMapFile);
inherited;
end;

详细源代码见报表服务和报表COM中的关于共享内存的源代码。需要注意创建共享内存需要放在：ServiceStart中初始化，不能放在initialization，否则还会出现权限不足的信息，因为initialization是在应用程序初始化之前执行的代码。

阿杰 发表于 2010-7-3 18:56:16

Delphi编写系统服务六：在服务中使用COM组件

在服务中调用COM组件不能像在桌面程序中直接创建，在每次创建之前先调用CoInitialize(nil)，释放的时候调用CoUninitialize。例如：调用ADO组件
var
Qry: TADOQuery;
begin
CoInitialize(nil);
Qry := TADOQuery.Create(nil);
try
    ...
finally
    Qry.Free;
    CoUninitialize;
end;
end;

阿杰 发表于 2010-7-3 18:56:43

Delphi编写系统服务七：完成端口演示

在开发大量Socket并发服务器，完成端口加重叠I/O是迄今为止最好的一种解决方案，下面是简单的介绍：
   “完成端口”模型是迄今为止最为复杂的一种I/O模型，特别适合需要同时管理为数众多的套接字，采用这种模型，往往可以达到最佳的系统性能。但是只适合Windows NT和Windows 2000及以上操作系统。因其设计的复杂性，只有在你的应用程序需要同时管理数百乃至上千套接字的时候，而且希望随着系统内安装的CPU数量增多，应用程序的性能也可以线性提升，才考虑采用“完成端口”模型。
    重叠I/O（Overlapped I/O）模型使应用程序达到更佳的系统性能。重叠模型的基本设计原理便是让应用程序使用一个重叠的数据结构，一次投递一个或多个Winsock I/O请求。针对哪些提交的请求，在它们完成之后，应用程序可为它们提供服务。该模型适用于除Windows CE之外的各种Windows平台。
    开发完成端口最具有挑战是线程个数和管理内存，创建一个完成端口后，就需要创建一个或多个“工作者线程”，以便在I/O请求投递给完成端口对象后，为完成端口提供服务。但是到底应创建多少个线程，这实际正是完成端口最为复杂的一个方面，一般采用的是为每一个CPU分配一个线程（有的是CPU个数加1，有的是CPU*2的线程个数）。内存分配效率低是因为应用程序在分配内存的时候，系统内核需要不停的Lock/UnLock，而且在多CPU的情况下，会成为整个程序性能的瓶颈，不能随CPU的个数增加而性能提高，一种比较好的做法一个一次分配多块内存。
    下面是我写一个的完成端口的演示程序，在我的电脑上测试可以达到链接5100个客服端，服务器性能还很好，由于我写的客服端占用资源比较的，最后直接重启了，具体见代码。演示程序主要的瓶颈在于发消息的这一块，在实际应用中应去掉。

（配置：操作系统 Microsoft Windows XP Professional 操作系统 Service Pack 版本 Service Pack 2；CPU：Intel(R) Pentium(R)4 2.40GHz 2.40GHz；内存：2G；主板：华硕P4P800）。

主要源代码：(Delphi 7编写)，下载地址：http://download.csdn.net/source/818039

{*******************************************************}
{                                                       }
{       高性能服务器，这个是一个演示DEMO                }
{                                                       }
{       联系邮箱：fansheng_hx@163.com                   }
{                                                       }
{*******************************************************}

unit IOCPSvr;

interface

uses
Windows, Messages, WinSock2, Classes, SysUtils, SyncObjs;

const
{* 每一次发送和接收的数据缓冲池大小 *}
MAX_BUFSIZE = 4096;
{* 关闭客户端通知消息 *}
WM_CLIENTSOCKET = WM_USER + $2000;

type
{* Windows Socket 消息 *}
TCMSocketMessage = packed record
    Msg: Cardinal;
    Socket: TSocket;
    SelectEvent: Word;
    SelectError: Word;
    Result: Longint;
end;

{* IOCP服务器运行轨迹 *}
TSocketEvent = (seInitIOPort, seUninitIOPort, seInitThread, seUninitThread,
    seInitSocket, seUninitSocket, seConnect, seDisconnect, seListen, seAccept, seWrite, seRead);
const
CSSocketEvent: array of string = ('InitIOPort', 'UninitIOPort', 'InitThread', 'UninitThread',
    'InitSocket', 'UninitSocket', 'Connect', 'Disconnect', 'Listen', 'Accept', 'Write', 'Read');
type
{* 产生错误类型 *}
TErrorEvent = (eeGeneral, eeSend, eeReceive, eeConnect, eeDisconnect, eeAccept);

{* 完成端口传递的结构体 *}
TIOCPStruct = packed record
    Overlapped: OVERLAPPED;
    wsaBuffer: TWSABUF;
    Event: TSocketEvent; //读或写
    Buffer: array of Char;
    Assigned: Boolean;//表示已经分配给某个客户端
    Active: Boolean;    //客服端内部使用，表示是否正在使用
end;
PIOCPStruct = ^TIOCPStruct;

EMemoryBuffer = class(Exception);
ESocketError = class(Exception);

TMemoryManager = class;
TServerSocket = class;
TSymmetricalSocket = class;

TMemoryManager = class
private
    {* 管理内存使用 *}
    FList: TList;
    {* 分配和释放时候使用的锁 *}
    FLock: TCriticalSection;
    {* 服务器 *}
    FServerSocket: TServerSocket;
    function GetCount: Integer;
    function GetIOCPStruct(AIndex: Integer): PIOCPStruct;
public
    constructor Create(AServerSocket: TServerSocket; ACount: Integer); overload;
    constructor Create(AServerSocket: TServerSocket); overload;
    destructor Destroy; override;

    {* 分配内存使用权 *}
    function Allocate: PIOCPStruct;
    {* 释放内存使用权 *}
    procedure Release(AValue: PIOCPStruct);
    property Server: TServerSocket read FServerSocket;
    property Count: Integer read GetCount;
    property Item: PIOCPStruct read GetIOCPStruct;
end;

{* 客服端链接服务器触发此事件，如果要拒绝链接，把AConnect := False *}
TOnBeforeConnect = procedure(ASymmIP: string; AConnect: Boolean) of object;
{* 链接完成之后触发此事件 *}
TOnAfterConnect = procedure(ASymmetricalSocket: TSymmetricalSocket) of object;
{* 断开连接触发事件 *}
TOnAfterDisconnect = procedure(ASymmetricalSocket: TSymmetricalSocket) of object;
{* 收到数据会触发此事件 *}
TOnDataEvent = procedure(ASymmetricalSocket: TSymmetricalSocket; AData: Pointer;
    ACount: Integer) of object;
{* 错误触发事件 *}
TonErrorEvent = procedure(AError: Integer; AErrorString: string; AInfo: string; var AHandleError: Boolean) of object;
{* 服务器运行LOG *}
TOnLog = procedure (ASocketEvent: TSocketEvent; AInfo: string) of object;

{* 服务器，负责建立完成端口，管理内存和管理客服端，及Socket消息循环 *}
TServerSocket = class
private
    {* 内存管理 *}
    FMemory: TMemoryManager;
    {* 端口 *}
    FPort: Integer;
    {* 套接字 *}
    FSocket: TSocket;
    {* 完成端口句柄 *}
    FIOCPHandle: THandle;
    {* 消息循环句柄 *}
    FHandle: THandle;
    {* 对等的客服端 *}
    FClients: TList;
    {* 服务器运行线程 *}
    FThreads: TList;
    {* 监听线程 *}
    FAcceptThread: TThread;
    {* 表示是否激活 *}
    FActive: Boolean;
    {* 锁 *}
    FLock: TCriticalSection;
    {* 错误触发事件 *}
    FonError: TonErrorEvent;
    {* 书写LOG *}
    FOnLog: TOnLog;
    {* 接收连接事件 *}
    FOnBeforeConnect: TOnBeforeConnect;
    {* 连接成功之后的事件 *}
    FOnAfterConnect: TOnAfterConnect;
    {* 断开连接事件 *}
    FOnAfterDisconnect: TOnAfterDisconnect;
    {* 接收数据 *}
    FOnRead: TOnDataEvent;

    procedure WndProc(var AMsg: TMessage);
    {* 激活 *}
    procedure Open;
    {* 关闭 *}
    procedure Close;
    {* 设置激活/关闭 *}
    procedure SetActive(AValue: Boolean);
    {* 触发错误 *}
    function CheckError(AErrorCode: Integer = -1; AInfo: string = ''): Boolean;
    {* 触发LOG *}
    procedure DoLog(ASocketEvent: TSocketEvent; AInfo: string = '');
    {* 设置端口 *}
    procedure SetPort(AValue: Integer);
    {* 注册一个客服端，由于在另外一个线程中调用，需要加锁 *}
    procedure RegisterClient(ASocket: TSymmetricalSocket);
    {* 反注册一个客服端，由于在另外一个线程中调用，需要加锁 *}
    procedure UnRegisterClient(ASocket: TSymmetricalSocket);
    {* 通过Socket句柄查找对等的TSymmetricalSocket *}
    function FindSymmClient(ASocket: TSocket): TSymmetricalSocket;
    {* 客服端关闭消息 *}
    procedure WMClientClose(var AMsg: TCMSocketMessage); message WM_CLIENTSOCKET;
    {* 连接时触发的事件 *}
    function DoConnect(ASocket: TSocket): Boolean;
    {* 连接完成之后触发事件 *}
    procedure DoAfterConnect(ASymSocket: TSymmetricalSocket);
    {* 连接断开触发事件 *}
    procedure DoDisConnect(ASymSocket: TSymmetricalSocket);
    {* 接收数据触发的事件 *}
    procedure DoRead(ASymmetricalSocket: TSymmetricalSocket; AData: Pointer;
      ACount: Integer);
    {* 获得客服端个数 *}
    function GetClientCount: Integer;
    function GetClient(const AIndex: Integer): TSymmetricalSocket;
public
    constructor Create;
    destructor Destroy; override;
    {* 接收一个客服端，被接收线程调用 *}
    procedure AcceptClient;

    property Port: Integer read FPort write SetPort;
    property Socket: TSocket read FSocket;
    property Handle: THandle read FHandle;
    property Active: Boolean read FActive write SetActive;
    property MemoryManager: TMemoryManager read FMemory;
    {* 事件 *}
    property onError: TonErrorEvent read FonError write FonError;
    property OnLog: TOnLog read FOnLog write FOnLog;
    property OnRead: TOnDataEvent read FOnRead write FOnRead;
    property OnBeforeConnect: TOnBeforeConnect read FOnBeforeConnect write FOnBeforeConnect;
    property OnAfterConnect: TOnAfterConnect read FOnAfterConnect write FOnAfterConnect;
    property OnAfterDisConnect: TOnAfterDisconnect read FOnAfterDisconnect write FOnAfterDisconnect;
    property ClientCount: Integer read GetClientCount;
    property Client: TSymmetricalSocket read GetClient;
end;

{* 接收数据、发送数据及管理分配的内存 *}
TSymmetricalSocket = class
private
    FSocket: TSocket;
    FServer: TServerSocket;
    FAssignMemory: TList;
    FRemoteAddress, FRemoteHost: string;
    FRemotePort: Integer;

    {* 准备接收数据 *}
    function PrepareRecv(AIOCPStruct: PIOCPStruct = nil): Boolean;
    {* 获得完成端口内存块使用权 *}
    function Allocate: PIOCPStruct;
    {* 处理接收的数据 *}
    function WorkBlock(AIOCPStruct: PIOCPStruct; ACount: DWORD): Integer;
    {* 获得地方IP *}
    function GetRemoteIP: string;
    {* 获得远程机器名 *}
    function GetRemoteHost: string;
    {* 获得远程端口 *}
    function GetRemotePort: Integer;
public
    constructor Create(ASvrSocket: TServerSocket; ASocket: TSocket);
    destructor Destroy; override;
    {* 发送数据 *}
    function Write(var ABuf; ACount: Integer): Integer;
    function WriteString(const AValue: string): Integer;

    property Socket: TSocket read FSocket;
    property RemoteAddress: string read GetRemoteIP;
    property RemoteHost: string read GetRemoteHost;
    property RemotePort: Integer read GetRemotePort;
end;

TSocketThread = class(TThread)
private
    FServer: TServerSocket;
public
    constructor Create(AServer: TServerSocket);
end;

TAcceptThread = class(TSocketThread)
protected
    procedure Execute; override;
end;

TWorkThread = class(TSocketThread)
protected
    procedure Execute; override;
end;

implementation

uses
RTLConsts;

const
SHUTDOWN_FLAG = $FFFFFFFF;

{ TMemoryManager }

constructor TMemoryManager.Create(AServerSocket: TServerSocket;
ACount: Integer);
var
i: Integer;
pIOCPData: PIOCPStruct;
begin
inherited Create;
FList := TList.Create;
FLock := TCriticalSection.Create;
for i := 1 to ACount do
begin
    New(pIOCPData);
    FillChar(pIOCPData^, SizeOf(PIOCPStruct), 0);
    {* 下面两句其实由FillChar已经完成，在这写，只是为了强调 *}
    pIOCPData.Assigned := False;
    pIOCPData.Active := False;
    FList.Add(pIOCPData);
end;
end;

function TMemoryManager.Allocate: PIOCPStruct;
var
i: Integer;
begin
FLock.Enter;
try
    Result := nil;
    for i := 0 to FList.Count - 1 do
    begin
      Result := FList;
      if not Result.Assigned then
      Break;
    end;
    if (not Assigned(Result)) or (Result.Assigned) then
    begin
      New(Result);
      FList.Add(Result);
    end;
    FillChar(Result^, SizeOf(TIOCPStruct), 0);
    Result.Assigned := True;
    Result.Active := False;
finally
    FLock.Leave;
end;
end;

constructor TMemoryManager.Create(AServerSocket: TServerSocket);
begin
Create(AServerSocket, 200);
end;

destructor TMemoryManager.Destroy;
var
i: Integer;
begin
for i := 0 to FList.Count - 1 do
    FreeMem(FList);
FList.Clear;
FList.Free;
FLock.Free;
inherited;
end;

function TMemoryManager.GetCount: Integer;
begin
Result := FList.Count;
end;

function TMemoryManager.GetIOCPStruct(AIndex: Integer): PIOCPStruct;
begin
Result := nil;
if (AIndex >= FList.Count) or (AIndex < 0) then
    EMemoryBuffer.CreateFmt(SListIndexError, )
else
    Result := FList;
end;

procedure TMemoryManager.Release(AValue: PIOCPStruct);
begin
FLock.Enter;
try
    AValue.Assigned := False;
    AValue.Active := False;
finally
    FLock.Leave;
end;
end;

{ TServerSocket }

constructor TServerSocket.Create;
begin
FMemory := TMemoryManager.Create(Self);
FClients := TList.Create;
FThreads := TList.Create;
FSocket := INVALID_SOCKET;
FLock := TCriticalSection.Create;

FPort := 6666;
FAcceptThread := nil;
FIOCPHandle := 0;
FHandle := AllocateHWnd(WndProc);
end;

destructor TServerSocket.Destroy;
begin
//关闭完成端口
SetActive(False);
FThreads.Free;
FClients.Free;
DeallocateHWnd(FHandle);
FMemory.Free;
FLock.Free;
inherited;
end;

procedure TServerSocket.Open;
var
SystemInfo: TSystemInfo;
i: Integer;
Thread: TThread;
Addr: TSockAddr;
WSData: TWSAData;
begin
try
    if WSAStartup($0202, WSData) <> 0 then
    begin
      raise ESocketError.Create('WSAStartup');
    end;
    DoLog(seInitIOPort);//初始化完成端口
    FIOCPHandle := CreateIoCompletionPort(INVALID_HANDLE_VALUE, 0, 0, 0);
    if FIOCPHandle = 0 then
      CheckError;

    DoLog(seInitThread); //初始化工作线程
    GetSystemInfo(SystemInfo);
    for i := 0 to SystemInfo.dwNumberOfProcessors * 2 -1 do
    begin
      Thread := TWorkThread.Create(Self);
      FThreads.Add(Thread);
    end;

    DoLog(seInitSocket); //建立套接字
    FSocket := WSASocket(PF_INET, SOCK_STREAM, 0, nil, 0, WSA_FLAG_OVERLAPPED);
    if FSocket = INVALID_SOCKET then CheckError;

    FillChar(Addr, SizeOf(TSockAddr), 0);
    Addr.sin_family := AF_INET;
    Addr.sin_port := htons(FPort);
    Addr.sin_addr.S_addr := htonl(INADDR_ANY);
    CheckError(bind(FSocket, @Addr, SizeOf(TSockAddr)), 'bind');

    DoLog(seListen);//开始监听
    CheckError(listen(FSocket, 5), 'listen');
    FAcceptThread := TAcceptThread.Create(Self);
except
    on E: Exception do
    begin
      Close;
      CheckError(GetLastError, E.Message);
    end;
end;
end;

procedure TServerSocket.Close;
var
i: Integer;
Thread: TThread;
begin
try
    WSACleanup;
    DoLog(seUninitSocket);
    FAcceptThread.Terminate;
    if FSocket <> INVALID_SOCKET then
    begin
      closesocket(FSocket);
      FSocket := INVALID_SOCKET;
    end;

    DoLog(seUninitThread);
    for i := FThreads.Count - 1 downto 0 do
    begin
      Thread := FThreads;
      Thread.Terminate;
      PostQueuedCompletionStatus(FIOCPHandle, 0, 0, Pointer(SHUTDOWN_FLAG))
    end;
    FThreads.Clear;

    for i := FClients.Count - 1 downto 0 do
    begin
      TSymmetricalSocket(FClients).Free;
    end;
    FClients.Clear;

    DoLog(seUninitIOPort);
    CloseHandle(FIOCPHandle);
    FIOCPHandle := 0;
except
    on E: Exception do
    begin
      Close;
      CheckError(-1, E.Message);
    end;
end;
end;

procedure TServerSocket.SetActive(AValue: Boolean);
begin
if FActive = AValue then Exit;
FActive := AValue;
if FActive then
    Open
else
    Close;
end;

procedure TServerSocket.WndProc(var AMsg: TMessage);
begin
try
    Dispatch(AMsg);
except
    if Assigned(ApplicationHandleException) then
      ApplicationHandleException(Self);
end;
end;

阿杰 发表于 2010-7-3 18:57:47

function TServerSocket.CheckError(AErrorCode: Integer; AInfo: string): Boolean;
var
HandleError: Boolean;
begin
Result := True;
if AErrorCode = 0 then Exit;
if AErrorCode = -1 then
    AErrorCode := WSAGetLastError;
if AErrorCode = -1 then
    AErrorCode := GetLastError;
if (AErrorCode <> WSAEWOULDBLOCK) and (AErrorCode <> ERROR_IO_PENDING) and
    (AErrorCode <> 0) then
begin
    if Assigned(FonError) then
    begin
      HandleError := False;
      FonError(AErrorCode, SysErrorMessage(AErrorCode), AInfo, HandleError);
      if HandleError then Exit;
    end;
    raise ESocketError.CreateFmt(SWindowsSocketError,
       );
end;
end;

procedure TServerSocket.DoLog(ASocketEvent: TSocketEvent; AInfo: string);
begin
if Assigned(FOnLog) then FOnLog(ASocketEvent, AInfo);
end;

procedure TServerSocket.DoRead(ASymmetricalSocket: TSymmetricalSocket;
AData: Pointer; ACount: Integer);
begin
if Assigned(FOnRead) then
    FOnRead(ASymmetricalSocket, AData, ACount);
end;

procedure TServerSocket.SetPort(AValue: Integer);
begin
if FActive then
    raise ESocketError.Create('IOCP is acitve, cann''t change port');
FPort := AValue;
end;

procedure TServerSocket.RegisterClient(ASocket: TSymmetricalSocket);
begin
FLock.Enter;
try
    if FClients.IndexOf(ASocket) = -1 then
    begin
      FClients.Add(ASocket);
      DoAfterConnect(ASocket);
      {* 注册关闭通知消息 *}
      WSAAsyncSelect(ASocket.Socket, FHandle, WM_CLIENTSOCKET, FD_CLOSE);
    end;
finally
    FLock.Leave;
end;
end;

procedure TServerSocket.UnRegisterClient(ASocket: TSymmetricalSocket);
var
iIndex: Integer;
begin
FLock.Enter;
try
    iIndex := FClients.IndexOf(ASocket);
    if iIndex <> -1 then
    begin
      FClients.Delete(iIndex);
      DoDisConnect(ASocket);
    end;
finally
    FLock.Leave;
end;
end;

procedure TServerSocket.AcceptClient;
var
Addr: TSockAddrIn;
iAddrLen: Integer;
ClientWinSocket: TSocket;
SymmSocket: TSymmetricalSocket;
begin
iAddrLen := SizeOf(TSockAddrIn);
ClientWinSocket := WinSock2.WSAAccept(Socket, nil, nil, nil, 0);
if ClientWinSocket <> INVALID_SOCKET then
begin
    if (not Active) or (not DoConnect(ClientWinSocket)) then
    begin
      closesocket(ClientWinSocket);
      Exit;
    end;
    try
      DoLog(seAccept);
      SymmSocket := TSymmetricalSocket.Create(Self, ClientWinSocket);
      DoLog(seConnect);
    except
      closesocket(ClientWinSocket);
      CheckError;
      Exit;
    end;
    if CreateIoCompletionPort(ClientWinSocket, FIOCPHandle, DWORD(SymmSocket), 0) = 0 then
    begin
      CheckError(GetLastError, 'CreateIoCompletionPort');
      SymmSocket.Free;
    end
    else
      SymmSocket.PrepareRecv;
end;
end;

procedure TServerSocket.DoAfterConnect(ASymSocket: TSymmetricalSocket);
begin
if Assigned(FOnAfterConnect) then FOnAfterConnect(ASymSocket);
end;

function TServerSocket.DoConnect(ASocket: TSocket): Boolean;
var
SockAddrIn: TSockAddrIn;
Size: Integer;
begin
Result := True;
if Assigned(FOnBeforeConnect) then
begin
    Size := SizeOf(TSockAddrIn);
    CheckError(getpeername(ASocket, SockAddrIn, Size), 'getpeername');
    FOnBeforeConnect(inet_ntoa(SockAddrIn.sin_addr), Result);
end;
end;

procedure TServerSocket.DoDisConnect(ASymSocket: TSymmetricalSocket);
begin
if Assigned(FOnAfterDisconnect) then FOnAfterDisconnect(ASymSocket);
end;

function TServerSocket.FindSymmClient(
ASocket: TSocket): TSymmetricalSocket;
var
i: Integer;
begin
Result := nil;
FLock.Enter;
try
    for i := 0 to FClients.Count - 1 do
    begin
      Result := FClients;
      if ASocket = Result.Socket then
      Break
      else
      Result := nil;
    end;
finally
    FLock.Leave;
end;
end;

function TServerSocket.GetClient(const AIndex: Integer): TSymmetricalSocket;
begin
Result := FClients;
end;

function TServerSocket.GetClientCount: Integer;
begin
Result := FClients.Count;
end;

procedure TServerSocket.WMClientClose(var AMsg: TCMSocketMessage);
var
ASymmSocket: TSymmetricalSocket;
begin
if AMsg.SelectEvent = FD_CLOSE then
begin
    ASymmSocket := FindSymmClient(AMsg.Socket);
    if Assigned(ASymmSocket) then
      ASymmSocket.Free;
end;
end;

{ TSocketThread }

constructor TSocketThread.Create(AServer: TServerSocket);
begin
FServer := AServer;
inherited Create(False);
FreeOnTerminate := True;
end;

{ TAcceptThread }

procedure TAcceptThread.Execute;
begin
inherited;
while not Terminated and FServer.Active do
begin
    FServer.AcceptClient;
end;
end;

{ TWorkThread }

procedure TWorkThread.Execute;
var
ASymSocket: TSymmetricalSocket;
AIOCPStruct: PIOCPStruct;
iWorkCount: Cardinal;
begin
inherited;
while (not Terminated) and (FServer.Active) do
begin
    AIOCPStruct := nil;
    iWorkCount := 0;
    ASymSocket := nil;
    if not GetQueuedCompletionStatus(FServer.FIOCPHandle, iWorkCount,
      DWORD(ASymSocket), POVerlapped(AIOCPStruct), INFINITE) then
    begin
      if Assigned(ASymSocket) then
      FreeAndNil(ASymSocket);
      Continue;
    end;

    if Cardinal(AIOCPStruct) = SHUTDOWN_FLAG then Break; //退出标志
    if not FServer.Active then Break; //退出

    {* 客户可能超时 或是断开连接，I/O失败 应放在通知结束的后面 *}
    if iWorkCount = 0 then
    begin
      //FreeAndNil(ASymSocket);//不在这儿释放，而是接收释放消息来释放
      Continue;
    end;
    FServer.DoLog(AIOCPStruct.Event);
    if ASymSocket.WorkBlock(AIOCPStruct, iWorkCount) = -1 then
    begin
      FreeAndNil(ASymSocket);
    end;
end;
end;

{ TSymmetricalSocket }

constructor TSymmetricalSocket.Create(ASvrSocket: TServerSocket;
ASocket: TSocket);
begin
FServer := ASvrSocket;
FSocket := ASocket;
FAssignMemory := TList.Create;
FServer.RegisterClient(Self);
//PrepareRecv;
end;

destructor TSymmetricalSocket.Destroy;
var
i: Integer;
Linger: TLinger;
begin
FServer.UnRegisterClient(Self);
FillChar(Linger, SizeOf(TLinger), 0);   //优雅关闭
setsockopt(FSocket, SOL_SOCKET, SO_LINGER, @Linger, Sizeof(Linger));
closesocket(FSocket);
for i := FAssignMemory.Count - 1 downto 0 do
    FServer.MemoryManager.Release(FAssignMemory);
FAssignMemory.Free;
inherited;
end;

function TSymmetricalSocket.Allocate: PIOCPStruct;
var
i: Integer;
begin
for i := 0 to FAssignMemory.Count - 1 do
begin
    Result := FAssignMemory;
    if not Result.Active then
    begin
      Result.Active := True;
      Exit;
    end;
end;
Result := FServer.MemoryManager.Allocate;
FAssignMemory.Add(Result);
Result.Active := True;
end;

function TSymmetricalSocket.PrepareRecv(AIOCPStruct: PIOCPStruct = nil): Boolean;
var
iFlags, iTransfer: Cardinal;
ErrCode: Integer;
begin
if not Assigned(AIOCPStruct) then
    AIOCPStruct := Allocate;
iFlags := 0;
AIOCPStruct.Event := seRead;
FillChar(AIOCPStruct.Buffer, SizeOf(AIOCPStruct.Buffer), 0);
FillChar(AIOCPStruct.Overlapped, SizeOf(AIOCPStruct.Overlapped), 0);
AIOCPStruct.wsaBuffer.buf := @AIOCPStruct.Buffer;
AIOCPStruct.wsaBuffer.len := MAX_BUFSIZE;
Result := WSARecv(FSocket, @AIOCPStruct.wsaBuffer, 1, @iTransfer, @iFlags, @AIOCPStruct.Overlapped, nil) <> SOCKET_ERROR;
if not Result then
begin
    ErrCode := WSAGetLastError;
    Result := ErrCode = ERROR_IO_PENDING;
    if not Result then
      FServer.CheckError(ErrCode, 'WSARecv');
end;
end;

function TSymmetricalSocket.WorkBlock(AIOCPStruct: PIOCPStruct;
ACount: DWORD): Integer;
var
ErrCode: Integer;
iSend, iFlag: Cardinal;
begin
Result := 0;
try
    case AIOCPStruct.Event of
      seRead://接收数据
      begin
      FServer.DoRead(Self, @AIOCPStruct.Buffer, ACount);
      if PrepareRecv(AIOCPStruct) then
          Result := ACount;
      end;
      seWrite: //发送数据
      begin
      Dec(AIOCPStruct.wsaBuffer.len, ACount);
      if AIOCPStruct.wsaBuffer.len <= 0 then
      begin
          AIOCPStruct.Active := False;
      end
      else
      begin
          FillChar(AIOCPStruct.Overlapped, SizeOf(AIOCPStruct.Overlapped), 0);
          iFlag := 0;
          if SOCKET_ERROR = WSASend(FSocket, @AIOCPStruct.wsaBuffer, 1, @iSend,
            iFlag, @AIOCPStruct.Overlapped, nil) then
          begin
            ErrCode := WSAGetLastError;
            if ErrCode <> ERROR_IO_PENDING then
            FServer.CheckError(ErrCode, 'WSASend');
          end
          else Result := iSend;
      end;
      end;
    end;
except
    Result := 0;
end;
end;

function TSymmetricalSocket.Write(var ABuf; ACount: Integer): Integer;
var
AIOCPStruct: PIOCPStruct;
ErrCode: Integer;
iFlag, iSend: Cardinal;
begin
Result := ACount;
if Result = 0 then Exit;
AIOCPStruct := Allocate;
iFlag := 0;
AIOCPStruct.Event := seWrite;
FillChar(AIOCPStruct.Buffer, SizeOf(AIOCPStruct.Buffer), 0);
CopyMemory(@AIOCPStruct.Buffer, @ABuf, ACount);
AIOCPStruct.wsaBuffer.buf := @AIOCPStruct.Buffer;
AIOCPStruct.wsaBuffer.len := Result;

if SOCKET_ERROR = WSASend(FSocket, @AIOCPStruct.wsaBuffer, 1, @iSend, iFlag,
    @AIOCPStruct.Overlapped, nil) then
begin
    ErrCode := WSAGetLastError;
    if ErrCode <> ERROR_IO_PENDING then
    begin
      Result := SOCKET_ERROR;
      FServer.CheckError(ErrCode, 'WSASend');
    end;
end;
end;

function TSymmetricalSocket.WriteString(const AValue: string): Integer;
begin
Result := Write(Pointer(AValue)^, Length(AValue));
end;

function TSymmetricalSocket.GetRemoteIP: string;
var
SockAddrIn: TSockAddrIn;
iSize: Integer;
HostEnt: PHostEnt;
begin
if FRemoteAddress = '' then
begin
    iSize := SizeOf(SockAddrIn);
    FServer.CheckError(getpeername(FSocket, SockAddrIn, iSize), 'getpeername');
    FRemoteAddress := inet_ntoa(SockAddrIn.sin_addr);
end;
Result := FRemoteAddress;
end;

function TSymmetricalSocket.GetRemotePort: Integer;
var
SockAddrIn: TSockAddrIn;
iSize: Integer;
HostEnt: PHostEnt;
begin
if FRemoteAddress = '' then
begin
    iSize := SizeOf(SockAddrIn);
    FServer.CheckError(getpeername(FSocket, SockAddrIn, iSize), 'getpeername');
    FRemotePort := ntohs(SockAddrIn.sin_port);
end;
Result := FRemotePort;
end;

function TSymmetricalSocket.GetRemoteHost: string;
var
SockAddrIn: TSockAddrIn;
iSize: Integer;
HostEnt: PHostEnt;
begin
if FRemoteAddress = '' then
begin
    iSize := SizeOf(SockAddrIn);
    FServer.CheckError(getpeername(FSocket, SockAddrIn, iSize), 'getpeername');
    HostEnt := gethostbyaddr(@SockAddrIn.sin_addr.S_addr, 4, PF_INET);
    if HostEnt <> nil then FRemoteHost := HostEnt.h_name;
end;
Result := FRemoteHost
end;

end.

upring 发表于 2015-5-1 16:34:15

哎 爱恨情仇的delphi

查看完整版本: ADO 存取数据库时的分页显示详