2005年07月29日

TCP/IPコネクション型ソケットで非同期通信する方法

TCP/IPのコネクション型ソケット(socket)を使い
プログラム同士を効率よく通信させたいのだけど、
処理をブロッキングすることなく通信させるには
どうしたらよいか悩んだことはありませんか?

今回はプログラム同士が
TCP/IP通信を実現するため、
接続、切断、受信、送信完了の
各事象をイベント駆動型で
プログラムに通知し効率よく通信させる
方法をDelphiでご紹介します。

一般的にTCP/IPのサーバタイプは特定の
サービスをクライアントに提供するため、
特定のポート番号でソケットをオープンし、
クライアントからの接続を待ちます。

一方、TCP/IPのクライアントは特定の
サービスをサーバに要求するため、
サービスを提供している相手(サーバ)と
そのサービスを表すポート番号へ、
ソケットを接続しサービスの要求を行います。

サービスの代表的なものに、
ftp、telnetなどは良くご存知かと思います。
もう少し具体的に見ていくと、
サーバ、クライアントの主な処理は次のようになります。

サーバ処理
説明
@サービスの開始
TCP/IPのストリームソケットを作成(socket)し、自分のIPアドレスとサービスを提供するポート番号をバインド(bind)する。
リッスン(listen)を行い、クライアントから接続を待つ。
サンプルプログラムは、終了するまでこのソケットを維持し、クライアントから接続の要求を受付け続ける。
A接続の受理
@のソケットにクライアントから接続要求があるか検査(select)する。
クライアントから接続要求があった場合、接続を受理(accept)する。
接続の受理に成功した場合、データ送受信用に新しいソケットが確保される。
以降のデータ送受信はこのソケットが使用される。
B要求の受信
Aのソケットでクライアントからデータを受信しているか検査(select)する。
受信データがある場合、取得(recv)する。
Cサービスの実行
クライアントの要求データでサーバのサービスを実行し、必要であれば応答データを戻す。
サンプルプログラムは、クライアントから受信したデータをそのままクライアントへ送信する。
D応答の送信
Cの処理でクライアントへ何らかの応答データを送信する場合、Aのソケットでクライアントへデータを送信できるか検査(select)する。
データを送信できる場合、送信(send)する。
E終了処理
全てのソケットを閉じ(closesocket/close)終了する。

クライアント処理
説明
@接続の要求
TCP/IPのストリームソケットを作成(socket)し、相手(サーバ)のIPアドレスとサーバのポート番号を設定し接続要求(connect)を行う。
サーバがクライアントの接続を受理した場合、接続は成功する。
サーバが不在かサーバのサービスが開始されていない場合、接続は失敗する。
A要求の送信
@のソケットでクライアントが要求データを送信できるか検査(select)する。
データを送信できる場合、送信(send)する。
サンプルプログラムは、画面で入力されたテキストを送信する。
B応答の受信
@のソケットでサーバから応答データを受信しているか検査(select)する。
受信データがある場合、取得(recv)する。
サンプルプログラムは、サーバがクライアントのデータをエコーバックするので、クライアントは自分が送信したテキストを受信する。
C終了処理
全てのソケットを閉じ(closesocket/close)終了する。

ここで問題になるのは
クライアントとサーバ間で
実際にやり取りするデータです。
送受信データの終わりはTCP/IP上に
実装されるプログラムの責任で行う必要があります。


送信データ長がウインドサイズを超えるような
データを送受信する場合、
送信側で仮に一回で送信できたとしても、
受信側では何回かに分けて受信することになります。
select関数はソケットに受信データがあるかないか、
送信できる状態であるかないかの情報は取得できても
送受信データがどこで終わっているか判断がつかないのです。

select関数の受信事象をそれぞれ
バラバラのデータと認識したのでは、
とんでもないことになりますね。
(初心者の方はよくやる失敗ですので注意してくださいね。)

サンプルプログラムは
この問題を回避するため、
送受信データの先頭に
ネットワークバイトオーダーのデータ長を付加し、
送信データが全て送信できた時に送信完了イベントを、
受信データを全て受信できた時に
受信イベントが発生するようになっています。

ではでは、早速サンプルプログラムを見ていただきましょう!

全ソースは【続きを読む】をクリック!

プログラムは若干複雑になってますが、
全ソースを公開しますので、
がんばって理解してくださいね。
また役に立ったと思われるあなた、
いつもの良く冷えた"ビ"がつくものおごってくださいね。(笑い)

【画面イメージ】

SocketTester.gif

関連書籍


Copyright guy@かしらもんじ でぇ〜

注意:
 下記ソースファイルは、本ページの管理者である「guy」が個人的に作成しました。
 このソースは作者に断り無く、個人がコピー、改造することは許可しますが、
 いかなる場合であっても、商用目的に使用することを固く禁じます。
 あと、ホームページでの公開の都合上、各ソースの先頭に全角スペースが入ってます。
 あなたがDelphiでコンパイルする前に、この全角スペースを半角スペースに変換してくださいね。

Delphi Project File: SockTester.dpr
program SockTester;

uses
 Forms,
 SockTesterUnit in 'SockTesterUnit.pas' {WinSockTester};

{$R *.res}

begin
 Application.Initialize;
 Application.CreateForm(TWinSockTester, WinSockTester);
 Application.Run;
end.


Delphi Form File: SockTesterUnit.dfm
object WinSockTester: TWinSockTester
 Left = 192
 Top = 107
 BorderIcons = [biSystemMenu, biMinimize]
 BorderStyle = bsSingle
 Caption = 'TCP/IP SockTester'
 ClientHeight = 345
 ClientWidth = 475
 Color = clBtnFace
 Font.Charset = SHIFTJIS_CHARSET
 Font.Color = clWindowText
 Font.Height = -12
 Font.Name = #65325#65331' '#65328#12468#12471#12483#12463
 Font.Style = []
 OldCreateOrder = False
 Position = poScreenCenter
 OnCreate = FormCreate
 OnDestroy = FormDestroy
 PixelsPerInch = 96
 TextHeight = 12
 object lblServer: TLabel
  Left = 32
  Top = 10
  Width = 33
  Height = 12
  Caption = 'Server'
 end
 object lblClient: TLabel
  Left = 36
  Top = 32
  Width = 30
  Height = 12
  Caption = 'Client'
 end
 object lblSendInterval: TLabel
  Left = 178
  Top = 54
  Width = 67
  Height = 12
  Caption = 'Send Interval'
 end
 object lblBlockTimer: TLabel
  Left = 4
  Top = 54
  Width = 62
  Height = 12
  Caption = 'Block Timer'
 end
 object lblSendData: TLabel
  Left = 12
  Top = 76
  Width = 53
  Height = 12
  Caption = 'Send Data'
 end
 object btnConnect: TButton
  Left = 318
  Top = 28
  Width = 75
  Height = 20
  Caption = 'Connect'
  TabOrder = 6
  OnClick = btnConnectClick
 end
 object btnSend: TButton
  Left = 396
  Top = 28
  Width = 75
  Height = 20
  Caption = 'Send'
  TabOrder = 7
  OnClick = btnSendClick
 end
 object Memo1: TMemo
  Left = 2
  Top = 94
  Width = 468
  Height = 120
  Font.Charset = SHIFTJIS_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = #65325#65331' '#12468#12471#12483#12463
  Font.Pitch = fpFixed
  Font.Style = []
  ParentFont = False
  ScrollBars = ssVertical
  TabOrder = 14
 end
 object Memo2: TMemo
  Left = 2
  Top = 218
  Width = 468
  Height = 120
  Font.Charset = SHIFTJIS_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = #65325#65331' '#12468#12471#12483#12463
  Font.Pitch = fpFixed
  Font.Style = []
  ParentFont = False
  ScrollBars = ssVertical
  TabOrder = 15
 end
 object chkTest: TCheckBox
  Left = 396
  Top = 52
  Width = 70
  Height = 17
  Caption = 'TEST !!'
  TabOrder = 12
  OnClick = chkTestClick
 end
 object edtSendInterval: TEdit
  Left = 248
  Top = 50
  Width = 65
  Height = 20
  TabOrder = 10
  Text = '1000'
 end
 object chkDump: TCheckBox
  Left = 318
  Top = 52
  Width = 70
  Height = 17
  Caption = 'DUMP !!'
  Checked = True
  State = cbChecked
  TabOrder = 11
 end
 object btnClose: TButton
  Left = 396
  Top = 6
  Width = 75
  Height = 20
  Caption = 'Close'
  TabOrder = 5
  OnClick = btnCloseClick
 end
 object btnOpen: TButton
  Left = 318
  Top = 6
  Width = 75
  Height = 20
  Caption = 'Open'
  TabOrder = 4
  OnClick = btnOpenClick
 end
 object edtSPort: TEdit
  Left = 70
  Top = 6
  Width = 65
  Height = 20
  TabOrder = 0
  Text = '2048'
 end
 object edtCPort: TEdit
  Left = 70
  Top = 28
  Width = 65
  Height = 20
  TabOrder = 2
  Text = '2048'
 end
 object edtSAddr: TEdit
  Left = 140
  Top = 6
  Width = 174
  Height = 20
  TabOrder = 1
  Text = '127.0.0.1'
 end
 object edtCAddr: TEdit
  Left = 140
  Top = 28
  Width = 174
  Height = 20
  TabOrder = 3
  Text = '127.0.0.1'
 end
 object edtBlockTimer: TEdit
  Left = 70
  Top = 50
  Width = 65
  Height = 20
  TabOrder = 8
  Text = '0'
 end
 object btnSet: TButton
  Left = 140
  Top = 52
  Width = 33
  Height = 18
  Caption = 'Set'
  TabOrder = 9
  OnClick = btnSetClick
 end
 object edtSendData: TEdit
  Left = 70
  Top = 72
  Width = 400
  Height = 20
  TabOrder = 13
  Text = 'Hello, This is buy. How are you? I'#39'm just so so...'
 end
 object Timer1: TTimer
  Enabled = False
  Left = 4
  Top = 96
 end
end


Delphi Source File: SockTesterUnit.pas
unit SockTesterUnit;

interface

uses
 Classes,
 Controls,
 Dialogs,
 ExtCtrls,
 Forms,
 Graphics,
 Messages,
 StdCtrls,
 SysUtils,
 Variants,
 Windows,
 //----------------------------------------------------------------------------
 Sock;

type
 TSockInfo = class
 public
  SockNo,
  SockType,
  RDCnt,
  SDCnt,
  ERCnt: Integer;
 end;
 //----------------------------------------------------------------------------
 TWinSockTester = class(TForm)
  Timer1: TTimer;
  lblServer: TLabel;
  lblClient: TLabel;
  lblBlockTimer: TLabel;
  lblSendInterval: TLabel;
  lblSendData: TLabel;
  edtSPort: TEdit;
  edtCPort: TEdit;
  edtSAddr: TEdit;
  edtCAddr: TEdit;
  edtSendData: TEdit;
  btnOpen: TButton;
  btnClose: TButton;
  btnConnect: TButton;
  btnSend: TButton;
  edtBlockTimer: TEdit;
  btnSet: TButton;
  edtSendInterval: TEdit;
  chkDump: TCheckBox;
  chkTest: TCheckBox;
  Memo1: TMemo;
  Memo2: TMemo;
  procedure FormCreate(Sender: TObject);
  procedure FormDestroy(Sender: TObject);
  procedure btnOpenClick(Sender: TObject);
  procedure btnCloseClick(Sender: TObject);
  procedure btnConnectClick(Sender: TObject);
  procedure btnSendClick(Sender: TObject);
  procedure chkTestClick(Sender: TObject);
  procedure btnSetClick(Sender: TObject);
 private
  FSockIF: TSockInterface;
  FSSocks,
  FCSocks: TList;
  procedure DisplaySocket;
  procedure TimerCallback(pSender: TObject);
  procedure EventCallback(pEvent: TSockEvent);
 public
 end;

var
 WinSockTester: TWinSockTester;

implementation

{$R *.dfm}

//------------------------------------------------------------------------------
function CoordinateDumpStrings(
 pBuffer: PChar; pSize: integer; pStrList: TStrings): TStrings;
const
 MAX_RECORDBYTE = 16;
 SP_Pad = ' ';
 SP_Pad2 = ' ';
 SP_Pad3 = '  ';
 SP_Pad4 = '  ';
 SP_PAD6 = '   ';
 TitlePattern = '0123456789ABCDEF';
var
 lLine : integer;
 li, lj : integer;
 lRecord : string;
 lTmp : string;
 lTmpSize : integer;
 lLineSize : integer;
 lTmpStr : string;
begin
 lRecord := SP_Pad6 + SP_Pad;
 for li := 0 to MAX_RECORDBYTE - 1 do
 begin
  lTmp := SP_Pad;
  if li = 15 then
   lTmp := '';
  lRecord := lRecord + IntToHex(li,2) + lTmp;
 end;
 lRecord := lRecord + SP_Pad3 + TitlePattern;
 pStrList.Add(lRecord);
 //
 lLine := Trunc(pSize / MAX_RECORDBYTE);
 lTmpSize := pSize - (lLine * MAX_RECORDBYTE);
 if lTmpSize <> 0 then
  inc(lLine)
 else
  lTmpSize := MAX_RECORDBYTE;
 for li := 1 to lLine do
 begin
  lTmpStr := '';
  if li = lLine then
   lLineSize := lTmpSize
  else
   lLineSize := MAX_RECORDBYTE;
  lRecord := IntToHex((li - 1)*MAX_RECORDBYTE, 6) + SP_Pad;
  for lj := 1 to MAX_RECORDBYTE do
  begin
   lTmp := SP_Pad;
   if lj = MAX_RECORDBYTE then
    lTmp := '';
   if lLineSize > 0 then
   begin
    lRecord := lRecord +
     IntToHex(Integer(pBuffer[((li-1)*MAX_RECORDBYTE)+(lj-1)]), 2) + lTmp;
    if (pBuffer[((0+li-1)*MAX_RECORDBYTE)+(lj-1)] >= Char($20)) AND
      (pBuffer[((0+li-1)*MAX_RECORDBYTE)+(lj-1)] < Char($80)) Then
     lTmpStr := lTmpStr + pBuffer[((li-1)*MAX_RECORDBYTE)+(lj-1)]
    else
     lTmpStr := lTmpStr + '.';
   end
   else
   begin
    lRecord := lRecord + SP_Pad2 + lTmp;
    lTmpStr := lTmpStr + SP_Pad;
   end;
   DEC(lLineSize);
  end;
  lRecord := lRecord + SP_Pad3 + lTmpStr;
  pStrList.Add(lRecord);
 end;
 result := pStrList;
end;

//------------------------------------------------------------------------------
procedure TWinSockTester.FormCreate(Sender: TObject);
begin
 FSockIF := TSockInterface.Create(Nil);
 FSockIF.OnCallback := EventCallback;
 FSockIF.BlockTimeout := StrToIntDef(edtBlockTimer.Text, 1000);
 FSockIF.Resume;
 //-----
 FSSocks := TList.Create;
 FCSocks := TList.Create;
end;

//------------------------------------------------------------------------------
procedure TWinSockTester.FormDestroy(Sender: TObject);
begin
 btnCloseClick(Nil);
 //-----
 FSockIF.Suspend;
 FSockIF.Free;
 //-----
 FSSocks.Free;
 FCSocks.Free;
end;

//------------------------------------------------------------------------------
procedure TWinSockTester.btnOpenClick(Sender: TObject);
var
 lRet: Integer;
 lItem: TSockInfo;
begin
 lRet := FSockIF.Open(edtSAddr.Text, StrToIntDef(edtSPort.Text, 1024));
 if (lRet >= 0) then
 begin
  lItem := TSockInfo.Create;
  lItem.SockNo  := lRet;
  lItem.SockType := SOCKTYPE_LISTEN;
  FSSocks.Add(lItem);
  //-----
  DisplaySocket;
 end;
end;

//------------------------------------------------------------------------------
procedure TWinSockTester.btnCloseClick(Sender: TObject);
begin
 while (FSSocks.Count > 0) do
 begin
  FSockIF.Close(TSockInfo(FSSocks[0]).SockNo);
  TSockInfo(FSSocks[0]).Free;
  FSSocks.Delete(0);
 end;
 //-----
 while (FCSocks.Count > 0) do
 begin
  FSockIF.Close(TSockInfo(FCSocks[0]).SockNo);
  TSockInfo(FCSocks[0]).Free;
  FCSocks.Delete(0);
 end;
 //-----
 DisplaySocket;
end;

//------------------------------------------------------------------------------
procedure TWinSockTester.btnConnectClick(Sender: TObject);
var
 lRet: Integer;
 lItem: TSockInfo;
begin
 lRet := FSockIF.Connect(edtCAddr.Text, StrToIntDef(edtCPort.Text,1024));
 if (lRet >= 0) then
 begin
  lItem := TSockInfo.Create;
  lItem.SockNo := lRet;
  FCSocks.Add(lItem);
  //-----
  DisplaySocket;
 end;
end;

//------------------------------------------------------------------------------
procedure TWinSockTester.btnSendClick(Sender: TObject);
var
 lCnt: Integer;
begin
 Randomize;
 //-----
 for lCnt := 0 to FSSocks.Count-1 do
 begin
  if (TSockInfo(FSSocks[lCnt]).SockType = SOCKTYPE_LISTEN) then
   continue;
  FSockIF.Send(TSockInfo(FSSocks[lCnt]).SockNo,
   Pointer(edtSendData.Text), Length(edtSendData.Text));
 end;
 //-----
 for lCnt := 0 to FCSocks.Count-1 do
 begin
  FSockIF.Send(TSockInfo(FCSocks[lCnt]).SockNo,
   Pointer(edtSendData.Text), Length(edtSendData.Text));
 end;
end;

//------------------------------------------------------------------------------
procedure TWinSockTester.btnSetClick(Sender: TObject);
begin
 FSockIF.BlockTimeout := StrToIntDef(edtBlockTimer.Text, 1000);
end;

//------------------------------------------------------------------------------
procedure TWinSockTester.chkTestClick(Sender: TObject);
begin
 Timer1.OnTimer := TimerCallback;
 Timer1.Interval := StrToIntDef(edtSendInterval.Text, 0);
 Timer1.Enabled := chkTest.Checked;
end;

//------------------------------------------------------------------------------
procedure TWinSockTester.DisplaySocket;
var
 lCnt: Integer;
 lItem: TSockInfo;
begin
 Memo2.Clear;
 //-----
 for lCnt := 0 to FSSocks.Count-1 do
 begin
  lItem := FSSocks[lCnt];
  Memo2.Lines.Add(Format('(%.6d)=RD:%.6d,SD:%.6d,ER:%.6d',
   [lItem.SockNo, lItem.RDCnt, lItem.SDCnt, lItem.ERCnt]));
 end;
 //-----
 for lCnt := 0 to FCSocks.Count-1 do
 begin
  lItem := FCSocks[lCnt];
  Memo2.Lines.Add(Format('(%.6d)=RD:%.6d,SD:%.6d,ER:%.6d',
   [lItem.SockNo, lItem.RDCnt, lItem.SDCnt, lItem.ERCnt]));
 end;
end;

//------------------------------------------------------------------------------
procedure TWinSockTester.TimerCallback(pSender: TObject);
begin
 btnSendClick(Nil);
end;

//------------------------------------------------------------------------------
procedure TWinSockTester.EventCallback(pEvent: TSockEvent);
 //----------------------------------------------------------------------------
 function dscon(pEvent: TSockEvent; pList: TList): Boolean;
 var
  lCnt: Integer;
  lItem: TSockInfo;
 begin
  Result := False;
  for lCnt := 0 to pList.Count-1 do
  begin
   lItem := pList[lCnt];
   if (lItem.SockNo = pEvent.SockNo) then
   begin
    pList.Remove(lItem);
    lItem.Free;
    Result := True;
    Break;
   end;
  end;
 end;
 //----------------------------------------------------------------------------
 function count(pEvent: TSockEvent; pList: TList): TSockInfo;
 var
  lCnt: Integer;
  lItem: TSockInfo;
 begin
  Result := Nil;
  for lCnt := 0 to pList.Count-1 do
  begin
   lItem := pList[lCnt];
   if (lItem.SockNo = pEvent.SockNo) then
   begin
    if (pEvent.Event = SOCKEVENT_RECV) then
     Inc(lItem.RDCnt)
    else
     Inc(lItem.SDCnt);
    if (pEvent.ErrorCode <> 0) then
     Inc(lItem.ERCnt);
    Result := lItem;
    Break;
   end;
  end;
 end;
var
 lCnt: Integer;
 lMsg: String;
 lItem: TSockInfo;
begin
 //----------------------------------------------------------------------------
 lMsg := Format('Event=%d, Error=%d, SockNo=%d, Size=%d',
  [pEvent.Event, pEvent.ErrorCode, pEvent.SockNo, pEvent.Size]);
 if (Memo1.Lines.Count > 200) then
 begin
  Memo1.Enabled := False;
  for lCnt := 0 to (Memo1.Lines.Count div 3) do
   Memo1.Lines.Delete(0);
  Memo1.Enabled := True;
 end;
 Memo1.Lines.Add(FormatDateTime('-----> yyyy/mm/dd hh:nn:ss ', Now)+lMsg);
 if (chkDump.Checked) and (pEvent.Size > 0) then
  CoordinateDumpStrings(pEvent.Data, pEvent.Size, Memo1.Lines);
 //----------------------------------------------------------------------------
 Case pEvent.Event of
 SOCKEVENT_ECON:
  begin
   lItem := TSockInfo.Create;
   lItem.SockNo  := pEvent.SockNo;
   lItem.SockType := SOCKTYPE_STRANS;
   FSSocks.Add(lItem);
  end;
 SOCKEVENT_DCON:
  begin
   if (not dscon(pEvent, FSSocks)) then dscon(pEvent, FCSocks);
  end;
 SOCKEVENT_RECV,
 SOCKEVENT_SEND:
  begin
   if (count(pEvent, FSSocks) = Nil) then Count(pEvent, FCSocks);
  end;
 end;
 DisplaySocket;
//TEST
{
 if (pEvent.Event = SOCKEVENT_RECV) and (pEvent.ErrorCode = 0) then
  FSockIF.Send(pEvent.SockNo, pEvent.Data, pEvent.Size);
}
end;

end.


Delphi Source File: Sock.pas
unit Sock;

interface

uses
 Classes,
 Math,
 SyncObjs,
 SysUtils,
 {$IFDEF _WIN}
 Messages,
 Windows,
 WinSock
 {$ELSE}
 KernelIoctl,
 Libc
 {$ENDIF}
 ;

const
 DATAMARK      = Chr($A)+Char($B)+Char($C);
 HEADSIZE      = Length(DATAMARK) + Sizeof(Integer);
 SENDSIZE      = 32768;
 RECVSIZE      = 65536;
 //----------------------------------------------------------------------------
 SOCKTYPE_LISTEN  = 0;
 SOCKTYPE_STRANS  = 1;
 SOCKTYPE_CTRANS  = 2;
 //----------------------------------------------------------------------------
 {$IFDEF _WIN}
 WM_EVENT      = WM_USER+101;
 {$ENDIF}
 SOCKEVENT_ECON   = 10;
 SOCKEVENT_DCON   = 20;
 SOCKEVENT_RECV   = 30;
 SOCKEVENT_SEND   = 40;
 //----------------------------------------------------------------------------
 ERR_TIMEOUT    = 9999;

type
 TSockEvent = class;
 TSockProcess = class;
 TSockInterface = class;
 //----------------------------------------------------------------------------
 TSockData = class
 public
  Data: PChar;
  Size,
  Index: Integer;
  Time1: TDateTime;
  destructor Destroy; override;
 end;
 //----------------------------------------------------------------------------
 TSockItem = class
 public
  SockNo,
  SockType: Integer;
  SockAddr: TSockAddr;
  SDList,
  RDList:  TList;
  constructor Create; virtual;
  destructor Destroy; override;
 end;
 //----------------------------------------------------------------------------
 TSockEvent = class
 public
  Event,
  ErrorCode,
  SockNo:  Integer;
  SockAddr: TSockAddr;
  Data:   PChar;
  Size:   Integer;
  destructor Destroy; override;
 end;
 //----------------------------------------------------------------------------
 TSockProcess = class(TThread)
 protected
  FIdx:  Integer;
  FSockIF: TSockInterface;
  function _Event(
   pItem: TSockItem;
    pEvent, pError: Integer; pData: TSockData): TSockEvent; virtual;
  function _Read(pItem: TSockItem): Boolean; virtual;
  function _Write(pItem: TSockItem): Boolean; virtual;
  procedure _Timeout; virtual;
  procedure _Post(pEvent: TSockEvent); virtual;
 public
  constructor Create(pOwner: TSockInterface); virtual;
  procedure Execute; override;
 end;
 //----------------------------------------------------------------------------
 TSockEventCB = procedure(pEvent: TSockEvent) of object;
 //----------------------------------------------------------------------------
 TSockInterface = class
 protected
  {$IFDEF _WIN}
  FHandle:    HWND;
  {$ENDIF}
  FCS:      TCriticalSection;
  FErrorCode:  Integer;
  FSockItems:  TList;
  FSockProcess: TSockProcess;
  FSockEventCB: TSockEventCB;
  FBlockTimeout: Integer;
  {$IFDEF _WIN}
  procedure OnMessage(var pMsg: TMessage); message WM_EVENT;
  {$ELSE}
  procedure OnMessage(pEvent: TSockEvent); virtual;
  {$ENDIF}
  function SetSocketOption(pSockNo: Integer): Boolean; virtual;
  procedure SetBlockTimeout(pTimeout: Integer); virtual;
 public
  constructor Create(pOwner: TObject); virtual;
  destructor Destroy; override;
  procedure Resume; virtual;
  procedure Suspend; virtual;
  function Open(pIPAddr: String; pPortNo: Integer): Integer; virtual;
  function Close(pSockNo: Integer): Integer; virtual;
  function Connect(pIPAddr: String; pPortNo: Integer): Integer; virtual;
  procedure Send(pSockNo: Integer; pData: Pointer; pSize: Integer); virtual;
  property CS: TCriticalSection
   read FCS write FCS;
  property ErrorCode: Integer
   read FErrorCode;
  property OnCallback: TSockEventCB
   read FSockEventCB write FSockEventCB;
  property BlockTimeout: Integer
   read FBlockTimeout write SetBlockTimeout;
 end;

implementation

{$IFDEF _WIN}
var
 CSockWindow: TWndClass = (
  style: 0;
  lpfnWndProc: @DefWindowProc;
  cbClsExtra: 0;
  cbWndExtra: 0;
  hInstance: 0;
  hIcon: 0;
  hCursor: 0;
  hbrBackground: 0;
  lpszMenuName: nil;
  lpszClassName: 'SockWindow');

//------------------------------------------------------------------------------
function AllocateHWnd(Method: TWndMethod): HWND;
var
 TempClass: TWndClass;
 ClassRegistered: Boolean;
begin
 CSockWindow.hInstance := HInstance;
 ClassRegistered := GetClassInfo(HInstance, CSockWindow.lpszClassName,
  TempClass);
 if not ClassRegistered or (TempClass.lpfnWndProc <> @DefWindowProc) then
 begin
  if ClassRegistered then
   Windows.UnregisterClass(CSockWindow.lpszClassName, HInstance);
  Windows.RegisterClass(CSockWindow);
 end;
 Result := CreateWindowEx(WS_EX_TOOLWINDOW, CSockWindow.lpszClassName,
  '', WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil);
 if Assigned(Method) then
  SetWindowLong(Result, GWL_WNDPROC, Longint(MakeObjectInstance(Method)));
end;

//------------------------------------------------------------------------------
procedure DeallocateHWnd(Wnd: HWND);
var
 Instance: Pointer;
begin
 Instance := Pointer(GetWindowLong(Wnd, GWL_WNDPROC));
 DestroyWindow(Wnd);
 if Instance <> @DefWindowProc then FreeObjectInstance(Instance);
end;
{$ENDIF}

//------------------------------------------------------------------------------
destructor TSockData.Destroy;
begin
 if (Data <> Nil) then
 begin
  FreeMem(Data);
  Data := Nil;
 end;

 inherited Destroy;
end;

//------------------------------------------------------------------------------
constructor TSockItem.Create;
begin
 SockNo  := -1;
 SockType := -1;

 SDList  := TList.Create;
 RDList  := TList.Create;
end;

//------------------------------------------------------------------------------
destructor TSockItem.Destroy;
begin
 //-----
 if (SDList <> Nil) then
 begin
  while (SDList.Count > 0) do
  begin
   TSockData(SDList.Items[0]).Free;
   SDList.Delete(0);
  end;
  SDList.Free;
  SDList := Nil;
 end;
 //-----
 if (RDList <> Nil) then
 begin
  while (RDList.Count > 0) do
  begin
   TSockData(RDList.Items[0]).Free;
   RDList.Delete(0);
  end;
  RDList.Free;
  RDList := Nil;
 end;
end;

//------------------------------------------------------------------------------
destructor TSockEvent.Destroy;
begin
 if (Data <> Nil) then
 begin
  FreeMem(Data);
  Data := Nil;
 end;

 inherited Destroy;
end;

//------------------------------------------------------------------------------
function TSockProcess._Event(
 pItem: TSockItem; pEvent, pError: Integer; pData: TSockData): TSockEvent;
begin
 Result := TSockEvent.Create;
 Result.Event   := pEvent;
 Result.ErrorCode := pError;
 Result.SockNo := pItem.SockNo;
 move(pItem.SockAddr, Result.SockAddr, Sizeof(Result.SockAddr));
 if (pData <> Nil) then
 begin
  Result.Size := pData.Size - HEADSIZE;
  GetMem(Result.Data, Result.Size);
  move(pData.Data[HEADSIZE], Result.Data^, Result.Size);
 end;
end;

//------------------------------------------------------------------------------
function TSockProcess._Read(pItem: TSockItem): Boolean;
var
 lSize,
 lRecv: Integer;
 lItem: TSockItem;
 lData: TSockData;
 lBuff: array[1..RECVSIZE] of Char;
 lDummy: Boolean;
 lEvent: TSockEvent;
 lError: Integer;
label
 Reload;
begin
 Result := False;
 lDummy := False;
 //----------------------------------------------------------------------------
 if (pItem.SockType = SOCKTYPE_LISTEN) then
 begin
  lItem := TSockItem.Create;
  lItem.SockNo  := accept(pItem.SockNo, @lItem.SockAddr, @lSize);
  lItem.SockType := SOCKTYPE_STRANS;
  if (FSockIF <> Nil) then
   FSockIF.SetSocketOption(lItem.SockNo);
  FSockIF.FSockItems.Add(lItem);
  _Post(_Event(lItem, SOCKEVENT_ECON, 0, Nil));
 end
 //----------------------------------------------------------------------------
 else
 begin
  Reload:
  //--------------------------------------------------------------------------
  if (pItem.RDList.Count = 0) then
  begin
   lData := TSockData.Create;
   lData.Size := HEADSIZE;
   GetMem(lData.Data, lData.Size);
   pItem.RDList.Add(lData);
  end
  else
   lData := pItem.RDList.Last;
  //--------------------------------------------------------------------------
  while (True) do
  begin
   if (lDummy) then
    lRecv := recv(pItem.SockNo, lBuff, RECVSIZE, 0)
   else
   begin
    lSize := lData.Size - lData.Index;
    lRecv := recv(
     pItem.SockNo, lData.Data[lData.Index], Min(lSize, RECVSIZE), 0);
   end;
   //------------------------------------------------------------------------
   if (lRecv < 0) then
   begin
    {$IFDEF _WIN}
    lError := WSAGetLastError;
    {$ELSE}
    lError := errno;
    {$ENDIF}
    Case lError of
     //-----
     EWOULDBLOCK:;
     //-----
     ECONNRESET,ECONNABORTED,ESHUTDOWN:
     begin
      _Post(_Event(pItem, SOCKEVENT_DCON, lError, Nil));
      if (pItem.SockType = SOCKTYPE_CTRANS) then
       shutdown(pItem.SockNo, 2);
      {$IFDEF _WIN}
      closesocket(pItem.SockNo);
      {$ELSE}
      __close(pItem.SockNo);
      {$ENDIF}
      FSockIF.FSockItems.Remove(pItem);
      pItem.Free;
      Result := True;
     end;
     //-----
     else
     begin
      _Post(_Event(pItem, SOCKEVENT_RECV, lError, Nil));
     end;
    end;
    Break;
   end
   //------------------------------------------------------------------------
   else if (lRecv = 0) then
   begin
    _Post(_Event(pItem, SOCKEVENT_DCON, 0, Nil));
    FSockIF.FSockItems.Remove(pItem);
    pItem.Free;
    Result := True;
    Break;
   end
   //------------------------------------------------------------------------
   else
   begin
    if (lDummy) then Continue;
    if (lData.Time1 <> 0) then lData.Time1 := Now;
    Inc(lData.Index, lRecv);
    if (lData.Index = lData.Size) then
    begin
     if (lData.Size <= HEADSIZE) then
     begin
      if (Copy(lData.Data, 1, Length(DATAMARK)) <> DATAMARK) then
      begin
       lData.Index := 0;
       lDummy := True;
       continue;
      end;
      move(lData.Data[Length(DATAMARK)], lSize, Sizeof(lSize));
      lSize := htonl(lSize);
      lData.Size := lSize;
      ReallocMem(lData.Data, lData.Size);
      lData.Time1 := Now;
      continue;
     end
     else
     begin
      _Post(_Event(pItem, SOCKEVENT_RECV, 0, lData));
      pItem.RDList.Remove(lData);
      lData.Free;
      goto Reload;
     end;
    end;
   end;
  end;
 end;
end;

//------------------------------------------------------------------------------
function TSockProcess._Write(pItem: TSockItem): Boolean;
var
 lSize,
 lSent: Integer;
 lData: TSockData;
 lEvent: TSockEvent;
 lError: Integer;
begin
 Result := False;
 //----------------------------------------------------------------------------
 if (pItem.SDList.Count <= 0) then Exit;
 //----------------------------------------------------------------------------
 lData := pItem.SDList.First;
 lSize := lData.Size - lData.Index;
 while (True) do
 begin
  lSent := send(
   pItem.SockNo, lData.Data[lData.Index], Min(lSize, SENDSIZE), 0);
  //--------------------------------------------------------------------------
  if (lSent < 0) then
  begin
   {$IFDEF _WIN}
   lError := WSAGetLastError;
   {$ELSE}
   lError := errno;
   {$ENDIF}
   Case lError of
    //-----
    EWOULDBLOCK:;
    //-----
    ECONNRESET,ECONNABORTED,ESHUTDOWN:
    begin
     _Post(_Event(pItem, SOCKEVENT_DCON, lError, Nil));
     if (pItem.SockType = SOCKTYPE_CTRANS) then
      shutdown(pItem.SockNo, 2);
     {$IFDEF _WIN}
     closesocket(pItem.SockNo);
     {$ELSE}
     __close(pItem.SockNo);
     {$ENDIF}
     FSockIF.FSockItems.Remove(pItem);
     pItem.Free;
     Result := True;
    end;
    //-----
    else
    begin
     _Post(_Event(pItem, SOCKEVENT_SEND, lError, lData));
     pItem.SDList.Remove(lData);
     lData.Free;
    end;
   end;
   Break;
  end
  //--------------------------------------------------------------------------
  else
  begin
   lData.Time1 := Now;
   Inc(lData.Index, lSent);
   Dec(lSize, lSent);
   if (lSize = 0) then
   begin
    _Post(_Event(pItem, SOCKEVENT_SEND, 0, lData));
    pItem.SDList.Remove(lData);
    lData.Free;
    Break;
   end;
  end;
 end;
end;

//------------------------------------------------------------------------------
procedure TSockProcess._Timeout;
var
 lCnt1,
 lCnt2: Integer;
 lItem: TSockItem;
 lData: TSockData;
 lTime: TDateTime;
 lEvent: TSockEvent;
begin
 lTime := Now;
 for lCnt1 := 0 to FSockIF.FSockItems.Count-1 do
 begin
  lItem := FSockIF.FSockItems[lCnt1];
  //-----
  lCnt2 := 0;
  while (lCnt2 < lItem.SDList.Count) do
  begin
   lData := lItem.SDList[lCnt2];
   if (lData.Time1 <> 0) then
   begin
    if ((lTime-lData.Time1) * 86400000 > FSockIF.FBlockTimeout) then
    begin
     _Post(_Event(lItem, SOCKEVENT_SEND, ERR_TIMEOUT, lData));
     lItem.SDList.Remove(lData);
     lData.Free;
     continue;
    end;
   end;
   Inc(lCnt2);
  end;
  //-----
  lCnt2 := 0;
  while (lCnt2 < lItem.RDList.Count) do
  begin
   lData := lItem.RDList[lCnt2];
   if (lData.Time1 <> 0) then
   begin
    if ((lTime-lData.Time1) * 86400000 > FSockIF.FBlockTimeout) then
    begin
{
     lData.Size := lData.Index;
     _Post(_Event(lItem, SOCKEVENT_RECV, ERR_TIMEOUT, lData));
}
     lItem.RDList.Remove(lData);
     lData.Free;
     continue;
    end;
   end;
   Inc(lCnt2);
  end;
 end;
end;

//------------------------------------------------------------------------------
procedure TSockProcess._Post(pEvent: TSockEvent);
begin
 if (FSockIF <> Nil) then
  {$IFDEF _WIN}
  PostMessage(FSockIF.FHandle, WM_EVENT, pEvent.Event, LPARAM(pEvent));
  {$ELSE}
  FSockIF.OnMessage(pEvent);
  {$ENDIF}
end;

//------------------------------------------------------------------------------
constructor TSockProcess.Create(pOwner: TSockInterface);
begin
 FSockIF := pOwner;

 inherited Create(True);
end;

//------------------------------------------------------------------------------
procedure TSockProcess.Execute;
var
 lRFD,
 lWFD: TFDSet;
 lCnt,
 lNum: Integer;
 lTim: timeval;
begin
 lTim.tv_sec := 0;
 lTim.tv_usec := 10;
 while (not Terminated) do
 begin
  sleep(1);
  //-----
  FSockIF.CS.Enter;
  //-----
  FD_ZERO(lRFD);
  FD_ZERO(lWFD);
  lNum := 0;
  for lCnt := 0 to FSockIF.FSockItems.Count-1 do
  begin
   FIdx := FIdx mod FSockIF.FSockItems.Count;
   lNum := Max(lNum, TSockItem(FSockIF.FSockItems[FIdx]).SockNo);
   FD_SET(TSockItem(FSockIF.FSockItems[FIdx]).SockNo, lRFD);
   FD_SET(TSockItem(FSockIF.FSockItems[FIdx]).SockNo, lWFD);
   Inc(FIdx);
  end;
  Inc(FIdx);
  //--------------------------------------------------------------------------
  if (select(lNum+1, @lRFD, @lWFD, Nil, @lTim) > 0) then
  begin
   lCnt := 0;
   while (lCnt < FSockIF.FSockItems.Count) do
   begin
    if (FD_ISSET(TSockItem(FSockIF.FSockItems[lCnt]).SockNo, lRFD)) then
    begin
     if (_Read(FSockIF.FSockItems[lCnt])) then continue;
    end;
    if (FD_ISSET(TSockItem(FSockIF.FSockItems[lCnt]).SockNo, lWFD)) then
    begin
     if (_Write(FSockIF.FSockItems[lCnt])) then continue;
    end;
    Inc(lCnt);
   end;
  end;
  if (FSockIF.FBlockTimeout > 0) then _Timeout;
  //-----
  FSockIF.CS.Release;
  //-----
 end;
end;

//------------------------------------------------------------------------------
{$IFDEF _WIN}
procedure TSockInterface.OnMessage(var pMsg: TMessage);
begin
 if (pMsg.Msg = WM_EVENT) then
 begin
  try
   if (Assigned(FSockEventCB)) then
    FSockEventCB(TSockEvent(pMsg.LParam));
  finally
   TSockEvent(pMsg.LParam).Free;
  end;
 end
 else
  DefWindowProc(FHandle, pMsg.Msg, pMsg.wParam, pMsg.lParam);
end;
{$ELSE}
procedure TSockInterface.OnMessage(pEvent: TSockEvent);
begin
 try
  if (Assigned(FSockEventCB)) then
   FSockEventCB(pEvent);
 finally
  pEvent.Free;
 end;
end;
{$ENDIF}

//------------------------------------------------------------------------------
function TSockInterface.SetSocketOption(pSockNo: Integer): Boolean;
var
 lArg1: Integer;
 lArg2: linger;
begin
 Result := False;
 try
  lArg1 := 1;
  {$IFDEF _WIN}
  if (ioctlsocket(pSockNo, FIONBIO, lArg1) <> 0) then
  {$ELSE}
  if (fcntl(pSockNo, F_SETFL, O_NONBLOCK) < 0) then
  {$ENDIF}
   Exit;
  lArg1 := 1;
  if (setsockopt(
   pSockNo, SOL_SOCKET, SO_KEEPALIVE, @lArg1, Sizeof(lArg1)) <> 0) then
   Exit;
  lArg1 := RECVSIZE;
  if (setsockopt(
   pSockNo, SOL_SOCKET, SO_RCVBUF, @lArg1, Sizeof(lArg1)) <> 0) then
   Exit;
  lArg1 := SENDSIZE;
  if (setsockopt(
   pSockNo, SOL_SOCKET, SO_SNDBUF, @lArg1, Sizeof(lArg1)) <> 0) then
   Exit;
  lArg2.l_onoff := 0;
  lArg2.l_linger := 0;
  if (setsockopt(
   pSockNo, SOL_SOCKET, SO_LINGER, @lArg2, Sizeof(lArg2)) <> 0) then
   Exit;
  Result := True;
 finally
  if (Result) then
   {$IFDEF _WIN}
   FErrorCode := WSAGetLastError;
   {$ELSE}
   FErrorCode := errno;
   {$ENDIF}
 end;
end;

//------------------------------------------------------------------------------
procedure TSockInterface.SetBlockTimeout(pTimeout: Integer);
begin
 //-----
 FCS.Enter;
 //-----
 FBlockTimeout := pTimeout;
 //-----
 FCS.Release;
 //-----
end;

//------------------------------------------------------------------------------
constructor TSockInterface.Create(pOwner: TObject);
{$IFDEF _WIN}
var
 lVer:  WORD;
 lSAD:  WSADATA;
{$ENDIF}
begin
 {$IFDEF _WIN}
 WSAStartup(lVer, lSAD);
 {$ENDIF}
 //-----
 {$IFDEF _WIN}
 FHandle    := AllocateHWnd(OnMessage);
 {$ENDIF}
 FCS      := TCriticalSection.Create;
 FSockItems  := TList.Create;
 FSockProcess := TSockProcess.Create(Self);
 FSockEventCB := Nil;
 FBlockTimeout := 0;
end;

//------------------------------------------------------------------------------
destructor TSockInterface.Destroy;
begin
 if (FSockProcess <> Nil) then
 begin
  FSockProcess.Terminate;
  FSockProcess.Free;
  FSockProcess := Nil;
 end;
 //-----
 if (FSockItems <> Nil) then
 begin
  while (FSockItems.Count > 0) do
  begin
   TSockItem(FSockItems[0]).Free;
   FSockItems.Delete(0);
  end;
  FSockItems.Free;
  FSockItems := Nil;
 end;
 //-----
 if (FCS <> Nil) then
 begin
  FCS.Free;
  FCS := Nil;
 end;
 //-----
 {$IFDEF _WIN}
 if (FHandle <> 0) then
 begin
  DeallocateHWnd(FHandle);
  FHandle := 0;
 end;
 //-----
 WSACleanup;
 {$ENDIF}

 inherited Destroy;
end;

//------------------------------------------------------------------------------
procedure TSockInterface.Resume;
begin
 FSockProcess.Resume;
end;

//------------------------------------------------------------------------------
procedure TSockInterface.Suspend;
begin
 FSockProcess.Suspend;
end;

//------------------------------------------------------------------------------
function TSockInterface.Open(pIPAddr: String; pPortNo: Integer): Integer;
var
 lItem: TSockItem;
begin
 Result := -1;
 lItem := TSockItem.Create;
 try
  lItem.SockNo := socket(AF_INET, SOCK_STREAM, 0);
  if (lItem.SockNo < 0) then
   Exit;
  lItem.SockType      := SOCKTYPE_LISTEN;
  lItem.SockAddr.sin_family := AF_INET;
  lItem.SockAddr.sin_port  := htons(pPortNo);
  lItem.SockAddr.sin_addr.S_addr := inet_addr(PChar(pIPAddr));
  if (bind(lItem.SockNo, lItem.SockAddr, Sizeof(lItem.SockAddr)) < 0) then
   Exit;
{
  if (not SetSocketOption(lItem.SockNo)) then
   Exit;
}
  if (listen(lItem.SockNo, 5) < 0) then
   Exit;
  //-----
  FCS.Enter;
  //-----
  FSockItems.Add(lItem);
  //-----
  FCS.Release;
  //-----
  Result := lItem.SockNo;
 finally
  {$IFDEF _WIN}
  FErrorCode := WSAGetLastError;
  {$ELSE}
  FErrorCode := errno;
  {$ENDIF}
  if (Result < 0) then
   if (lItem <> Nil) then lItem.Free;
 end;
end;

//------------------------------------------------------------------------------
function TSockInterface.Close(pSockNo: Integer): Integer;
var
 lCnt: Integer;
 lItem: TSockItem;
begin
 Result := -1;
 for lCnt := 0 to FSockItems.Count-1 do
 begin
  lItem := FSockItems[lCnt];
  if (lItem.SockNo = pSockNo) then
  begin
   //-----
   FCS.Enter;
   //-----
   if (lItem.SockType = SOCKTYPE_CTRANS) then
    shutdown(lItem.SockNo, 2);
   {$IFDEF _WIN}
   Result := closesocket(lItem.SockNo);
   {$ELSE}
   Result := __close(lItem.SockNo);
   {$ENDIF}
   FSockItems.Remove(lItem);
   lItem.Free;
   //-----
   FCS.Release;
   //-----
   Break;
  end;
 end;
end;

//------------------------------------------------------------------------------
function TSockInterface.Connect(pIPAddr: String; pPortNo: Integer): Integer;
var
 lItem: TSockItem;
begin
 Result := -1;
 lItem := TSockItem.Create;
 try
  lItem.SockNo := socket(AF_INET, SOCK_STREAM, 0);
  if (lItem.SockNo < 0) then
   Exit;
  lItem.SockType      := SOCKTYPE_CTRANS;
  lItem.SockAddr.sin_family := AF_INET;
  lItem.SockAddr.sin_port  := htons(pPortNo);
  lItem.SockAddr.sin_addr.S_addr := inet_addr(PChar(pIPAddr));
  {$IFDEF _WIN}
  if (WinSock.connect(
  {$ELSE}
  if (Libc.connect(
  {$ENDIF}
   lItem.SockNo, lItem.SockAddr, Sizeof(lItem.SockAddr)) < 0) then
   Exit;
  if (not SetSocketOption(lItem.SockNo)) then
   Exit;
  //-----
  FCS.Enter;
  //-----
  FSockItems.Add(lItem);
  //-----
  FCS.Release;
  //-----
  Result := lItem.SockNo;
 finally
  {$IFDEF _WIN}
  FErrorCode := WSAGetLastError;
  {$ELSE}
  FErrorCode :=errno;
  {$ENDIF}
  if (Result < 0) then
   if (lItem <> Nil) then lItem.Free;
 end;
end;

//------------------------------------------------------------------------------
procedure TSockInterface.Send(
 pSockNo: Integer; pData: Pointer; pSize: Integer);
var
 lCnt,
 lSize: Integer;
 lItem: TSockItem;
 lData: TSockData;
begin
 for lCnt := 0 to FSockItems.Count-1 do
 begin
  lItem := FSockItems[lCnt];
  if (lItem.SockNo = pSockNo) then
  begin
   lData := TSockData.Create;
   lData.Size := pSize + HEADSIZE;
   GetMem(lData.Data, lData.Size);
   move(DATAMARK, lData.Data^, Length(DATAMARK));
   lSize := htonl(lData.Size);
   move(lSize, lData.Data[Length(DATAMARK)], Sizeof(lSize));
   move(pData^, lData.Data[HEADSIZE], pSize);
   //-----
   FCS.Enter;
   //-----
   lItem.SDList.Add(lData);
   //-----
   FCS.Release;
   //-----
   Break;
  end;
 end;
end;

end.

posted by guy at 07:20 | 通信編
×

この広告は1年以上新しい記事の投稿がないブログに表示されております。