servermain.pas

iocp小程序

unit ServerMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, IOCPSvr, StdCtrls, ExtCtrls, ComCtrls;

const
  WM_Count = WM_USER + 1001;
  WM_Message = WM_USER + 1002;
  WM_Error = WM_USER + 1003;
  WM_Log = WM_USER + 1004;
type
  TFmMain = class(TForm)
    pnl1: TPanel;
    lbl1: TLabel;
    edtPort: TEdit;
    btnStart: TButton;
    btnStop: TButton;
    stat1: TStatusBar;
    mmoMessage: TMemo;
    pnl2: TPanel;
    btnSend: TButton;
    grp1: TGroupBox;
    grp2: TGroupBox;
    grp3: TGroupBox;
    mmoError: TMemo;
    mmoLog: TMemo;
    pnl5: TPanel;
    pnl6: TPanel;
    spl1: TSplitter;
    spl3: TSplitter;
    edtSend: TEdit;
    cbbClient: TComboBox;
    lbl2: TLabel;
    tmrMemory: TTimer;
    procedure btnStopClick(Sender: TObject);
    procedure btnStartClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure btnSendClick(Sender: TObject);
    procedure cbbClientDropDown(Sender: TObject);
    procedure tmrMemoryTimer(Sender: TObject);
  private
    FServer: TServerSocket;
    procedure AfterConnect(ASymmetricalSocket: TSymmetricalSocket);
    procedure AfterDisconnect(ASymmetricalSocket: TSymmetricalSocket);
    procedure OnRead(ASymmetricalSocket: TSymmetricalSocket; AData: Pointer;
      ACount: Integer);
    procedure OnError(AError: Integer; AErrorString: string; AInfo: string; var AHandleError: Boolean);
    procedure OnLog(ASocketEvent: TSocketEvent; AInfo: string);
  public
    procedure WMCount(var AMsg: TMessage); message WM_Count;
    procedure WMMessage(var AMsg: TMessage); message WM_Message;
    procedure WMError(var AMsg: TMessage); message WM_Error;
    procedure WMLog(var AMsg: TMessage); message WM_Log;
  end;

var
  FmMain: TFmMain;

implementation

{$R *.dfm}

procedure TFmMain.btnStartClick(Sender: TObject);
var
  iPort: Integer;
begin
  iPort := StrToInt(edtPort.Text);
  FServer.Port := iPort;
  FServer.Active := True;       
  btnStart.Enabled := False;
  btnStop.Enabled := True;
end;

procedure TFmMain.btnStopClick(Sender: TObject);
begin
  FServer.Active := False;
  btnStart.Enabled := True;
  btnStop.Enabled := False;
end;

procedure TFmMain.FormCreate(Sender: TObject);
begin
  FServer := TServerSocket.Create;
  FServer.OnAfterConnect := AfterConnect;
  FServer.OnAfterDisConnect := AfterDisconnect;
  FServer.OnRead := OnRead;
  FServer.OnError := OnError;
  FServer.OnLog := OnLog;
end;

procedure TFmMain.FormDestroy(Sender: TObject);
begin
  if FServer.Active then
    FServer.Active := False;
  FServer.Free;
end;

procedure TFmMain.OnError(AError: Integer; AErrorString, AInfo: string;
  var AHandleError: Boolean);
var
  pBuf: PChar;
  sError: string;
begin
  AHandleError := True;
  sError := 'Error Code: ' + IntToStr(AError) + '; Error String: ' + AErrorString
    + '; Info: ' + AInfo;  
  GetMem(pBuf, Length(sError)+1);
  CopyMemory(@pBuf[0], @sError[1], Length(sError));
  pBuf[Length(sError)] := #0;
  //内存在接收方释放，否则会造成内存泄漏
  SendMessage(Handle, WM_Error, WParam(@pBuf[0]), 0);
end;

procedure TFmMain.OnLog(ASocketEvent: TSocketEvent; AInfo: string);
var
  pBuf: PChar;
  sLog: string;
begin
  sLog := 'Event: ' + CSSocketEvent[ASocketEvent] + '; Info: ' + AInfo;
  GetMem(pBuf, Length(sLog)+1);
  CopyMemory(@pBuf[0], @sLog[1], Length(sLog));
  pBuf[Length(sLog)] := #0;
  //内存在接收方释放，否则会造成内存泄漏
  SendMessage(Handle, WM_Log, WParam(@pBuf[0]), 0);
end;

procedure TFmMain.OnRead(ASymmetricalSocket: TSymmetricalSocket; AData: Pointer;
  ACount: Integer);
var
  pBuf: PChar;
  sSocket: string;
  iLen: Integer;
begin
  sSocket := IntToStr(ASymmetricalSocket.Socket) + ': ';
  iLen := ACount + Length(sSocket);
  GetMem(pBuf, iLen+1);
  CopyMemory(@pBuf[0], @sSocket[1], Length(sSocket));
  CopyMemory(@pBuf[Length(sSocket)], AData, ACount);
  pBuf[iLen] := #0;
  //内存在接收方释放，否则会造成内存泄漏
  SendMessage(Handle, WM_Message, WParam(@pBuf[0]), 0);
end;

procedure TFmMain.WMCount(var AMsg: TMessage);
var
  i: Integer;
begin
  stat1.Panels[0].Text := 'Clinet Count: ' + IntToStr(AMsg.WParam);
  cbbClient.Items.Clear;
end;

procedure TFmMain.WMError(var AMsg: TMessage);
var
  sError: string;
begin
  sError := PChar(AMsg.WParam);
  FreeMem(PChar(AMsg.WParam));
  mmoError.Lines.Add(DateTimeToStr(Now) + ': ' + sError);
end;

procedure TFmMain.WMLog(var AMsg: TMessage);
var
  sLog: string;
begin
  sLog := PChar(AMsg.WParam);
  FreeMem(PChar(AMsg.WParam));
  mmoLog.Lines.Add(DateTimeToStr(Now) + ': ' + sLog);
end;

procedure TFmMain.WMMessage(var AMsg: TMessage);
var
  sMessage: string;
begin
  sMessage := PChar(AMsg.WParam);
  FreeMem(PChar(AMsg.WParam));
  mmoMessage.Lines.Add(DateTimeToStr(Now) + ': ' + sMessage);
end;

procedure TFmMain.AfterConnect(ASymmetricalSocket: TSymmetricalSocket);
begin
  SendMessage(Handle, WM_Count, FServer.ClientCount, 0);
end;

procedure TFmMain.AfterDisconnect(ASymmetricalSocket: TSymmetricalSocket);
begin
  SendMessage(Handle, WM_Count, FServer.ClientCount, 0);
end;

procedure TFmMain.btnSendClick(Sender: TObject);
begin
  if cbbClient.ItemIndex = -1 then
  begin
    MessageBox(Handle, '请选择你要发送数据的客户端', '提示', MB_OK+MB_ICONINFORMATION);
    Exit;
  end;
  FServer.Client[cbbClient.ItemIndex].WriteString(edtSend.Text + #13#10);
end;

procedure TFmMain.cbbClientDropDown(Sender: TObject);
var
  i: Integer;
begin
  cbbClient.Items.Clear;
  for i := 0 to FServer.ClientCount - 1 do
  begin
    cbbClient.Items.Add('Socket Handle: ' + IntToStr(FServer.Client[i].Socket)
      + '; Remote Address: ' + FServer.Client[i].RemoteAddress
      + '; Remote Port: ' + IntToStr(FServer.Client[i].RemotePort));
  end;
end;

procedure TFmMain.tmrMemoryTimer(Sender: TObject);
begin
  stat1.Panels[1].Text := 'Memory Count: ' + IntToStr(FServer.MemoryManager.Count);
end;

end.