IndyClient/Server程序示例

 Indy Client / Server 程序示例
     by Mats Asplund　翻译：菩提葡萄
     re-printed with permission of the author
     original source from http://go.to/masdp
 

这是一个使用Indy控件实现的Client/Server应用示例，分为客户/服务器两个程序。

当一个客户端连接到服务端程序时，服务端程序将返回一个0－9的标识符给客户端，并用一个小方块表示客户端程序的工作状态，而客户端程序每5秒钟改变一次工作状态（”工作/空闲“"working / idle"）。当客户端断开时相应的方块将不可见，它的ID号也将释放并会分配给下一个连接上来的客户端程序。如果连接的客户端超过十个，服务器将返回一个”Full“标识给新连接上来的客户端。

Indy 组件是一套开放源代码的Blocking模式Socket组件，可以从这里免费下载：
 www.nevrona.com/indy.

本示例程序可在这里下载

{----------------------------------------------------------------------

 Unit Name: sUnit

 Author:    Mats Asplund, 2001-11-09

 Purpose:   Indy client/server示例, 服务器部分

----------------------------------------------------------------------}



unit sUnit;



interface



uses

  Windows, Messages, SysUtils, Variants, Classes, Graphics, 

  Controls, Forms, Dialogs, IdBaseComponent, IdComponent, IdTCPServer, 

  StdCtrls, ExtCtrls;



type

  TForm1 = class(TForm)

    IdTCPServer1: TIdTCPServer;

    Timer1: TTimer;

    Memo1: TMemo;

    Label2: TLabel;

    Edit1: TEdit;

    procedure IdTCPServer1Execute(AThread: TIdPeerThread);

    procedure FormCreate(Sender: TObject);

    procedure FormClose(Sender: TObject; var Action: TCloseAction);

    procedure IdTCPServer1Connect(AThread: TIdPeerThread);

    procedure IdTCPServer1Disconnect(AThread: TIdPeerThread);

    procedure FormActivate(Sender: TObject);

  private

    ClientList: TStringList;

    ClientStatus: array[0..9] of TShape;

    procedure ShowClientStatus;

    { Private declarations }

  public

    { Public declarations }

  end;



var

  Form1: TForm1;



implementation



uses IdTCPConnection;



{$R *.dfm}



procedure TForm1.IdTCPServer1Execute(AThread: TIdPeerThread);

var

  ClientMsg: string;

begin

  with AThread.Connection do

  begin

// 读信息

    ClientMsg := ReadLn(', -2);

// 如果客户端断开连接，则从ClintList中删除之

    if Pos('disconnecting...', ClientMsg) > 1 then

    begin

      ClientList.Delete(ClientList.IndexOf(Copy(ClientMsg, 7, 1)));

      ClientStatus[StrToInt(Copy(ClientMsg, 7, 1))].Visible := false;

    end

    else

// 否则按客户端状态更新图块

      if Pos('working', ClientMsg) > 1 then

      begin

        ClientStatus[StrToInt(Copy(ClientMsg, 7, 1))].Visible := true;

        ClientStatus[StrToInt(Copy(ClientMsg, 7, 1))].Brush.Color := clLime;

      end

      else

      begin

        ClientStatus[StrToInt(Copy(ClientMsg, 7, 1))].Visible := true;

        ClientStatus[StrToInt(Copy(ClientMsg, 7, 1))].Brush.Color := clRed;

      end;

    Edit1.Text := ClientMsg;

  end;

  ShowClientStatus;

end;



procedure TForm1.FormCreate(Sender: TObject);

begin

  ClientList := TStringList.Create;

end;



procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

var

  n: integer;

begin

  ClientList.Free;

  for n := 0 to 9 do

    ClientStatus[n].Free;

end;



procedure TForm1.ShowClientStatus;

begin

  Memo1.Lines.Text := ClientList.Text;

end;



procedure TForm1.IdTCPServer1Connect(AThread: TIdPeerThread);

var

  n: integer;

  Full: boolean;

begin

  with AThread.Connection do

  begin

    Full:= true;

    for n := 0 to 9 do

// 取第一个空闲的标识

      if (ClientList.IndexOf(IntToStr(n)) = -1) then

      begin

        ClientList.Add(IntToStr(n));

// 将标识返回到客户端

        WriteLn(IntToStr(n));

        Full:= false;

        Break;

      end;

    if Full then WriteLn('Server full');

  end;

  ShowClientStatus;

end;



procedure TForm1.IdTCPServer1Disconnect(AThread: TIdPeerThread);

begin

  ShowClientStatus;

end;



procedure TForm1.FormActivate(Sender: TObject);

var

  n: integer;

begin

// 建立十个不可见的块图

  for n := 0 to 9 do

  begin

    ClientStatus[n] := TShape.Create(Self);

    ClientStatus[n].Parent := Form1;

    ClientStatus[n].Height := 10;

    ClientStatus[n].Width := 10;

    ClientStatus[n].Shape := stRectangle;

    ClientStatus[n].Top := 35;

    ClientStatus[n].Left := 8 + (15 * n);

    ClientStatus[n].Visible := false;

  end;

end;



end.

{----------------------------------------------------------------------

 Unit Name: cUnit

 Author:    Mats Asplund, 2001-11-09

 Purpose:   Indy client/server示例, 客户端部分

----------------------------------------------------------------------}



unit cUnit;



interface



uses

  Windows, Messages, SysUtils, Variants, Classes, Graphics, 

  Controls, Forms, Dialogs, IdBaseComponent, IdComponent, IdTCPConnection, 

  IdTCPClient, ExtCtrls, StdCtrls;



type

  TForm1 = class(TForm)

    Timer1: TTimer;

    IdTCPClient1: TIdTCPClient;

    Label1: TLabel;

    Shape1: TShape;

    Edit1: TEdit;

    Label2: TLabel;

    Button1: TButton;

    procedure Timer1Timer(Sender: TObject);

    procedure FormClose(Sender: TObject; var Action: TCloseAction);

    procedure Button1Click(Sender: TObject);

    procedure FormCreate(Sender: TObject);

  private

    ServerDown, Idle: Boolean;

    ClientNo: string;

    { Private declarations }

  public

    { Public declarations }

  end;



var

  Form1: TForm1;



implementation



{$R *.dfm}



procedure TForm1.Timer1Timer(Sender: TObject);

begin

  try

    with IdTCPClient1 do

    begin

      Timer1.Interval:= 5000;

// Turn off timer in case of server going down.

      Timer1.Enabled:= false;

      Idle:= not Idle;

      if Idle then

      begin

        Writeln('Client' + ClientNo + ' idle...');

        Shape1.Brush.Color:= clRed;

// Turn it on again

        Timer1.Enabled:= true;

      end

      else

      begin

        Writeln('Client' + ClientNo + ' working...');

        Shape1.Brush.Color:= clLime;

// Turn it on again

        Timer1.Enabled:= true;

      end;

    end;

  except

    on E: Exception do

    begin

      MessageDlg('The server is down.' + #13#10 +

        'Restart the client some other time.', mtError, [mbOK], 0);

      LAbel1.Caption:= 'No contact with server..';

      ServerDown:= true;

    end;

  end;

end;



procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

  if not ServerDown then

    with IdTCPClient1 do

    begin

      Writeln('Client' + ClientNo + ' disconnecting...');

      Disconnect;

    end;

  Action:= caFree;

end;



procedure TForm1.Button1Click(Sender: TObject);

begin

  try

    Timer1.Interval:= 1000;

    Timer1.Enabled:= true;

// 连接到服务器

    with IdTCPClient1 do

    begin

      Host:= Edit1.Text;

      Connect;

// 读服务器返回的标识

      ClientNo:= Readln(', 5000); // Timeout 5 secs

      if ClientNo = 'Server full' then

      begin

        MessageDlg('There's already ten clients connected. ' + #13#10 +

          'Try connecting some other time !', mtWarning, [mbOK], 0);

      end

      else

        if ClientNo = ' then

        begin

          Label1.Caption:= 'Client' + ClientNo + ' connection refused...';

        end

        else

        begin

// Connection accepted by server.

          ServerDown:= false;

          Caption:= 'Client' + ClientNo;

          Button1.Enabled:= false;

          Label1.Caption:= 'Client' + ClientNo + ' connection accepted...';

        end;

    end;

  except

    on E: Exception do

    begin

      Label1.Caption:= 'Client' + ClientNo + ' connection refused...';

    end;

  end;

end;



procedure TForm1.FormCreate(Sender: TObject);

begin

  ServerDown:= true;

end;



end.