开发一个基于DCOM的多房间局域网聊天室

题外话：这几篇是很早以前写的了，写的不好，先发上来给大家看看

开发一个基于DCOM的局域网聊天室

关键词：Delphi / 接口 / OLE&COM&DCOM / Win32


在前面的几篇文章中我们已经探讨了不少基于微软COM的相关技术，而分布式COM（以下简称DCOM）的出现给我们轻松的创建分布式应用提供了机会；我们可以完全不去理会低级别的Windows Sockets（DCOM通过MS-RPC让客户与对象进行通信，幸运的是要开发COM应用，开发者几乎可以不去理会MS-RPC）而开发出功能强大、偶合性低（功能模块相对独立，很好的发挥了OO的思想）、易于部署的分布式计算系统。
在这次的文章中，我们就打算使用DCOM来开发一个局域网聊天室，不仅是作为技术上的研究，实际上我相信这应该也是一个有用的工具。首先我们要对这个聊天室的功能有一个大致的了解：1、至少这个聊天室应该允许多个局域网用户进行聊天。（有点废话。。。）2、应该能够有多个话题的子聊天室，用户可以选择进入某个聊天室进行聊天。3、客户端应该尽量简单（不用配置DCOM），并需要一个服务器端管理所有的交互行为，管理聊天室的数目和相关配置，并做好系统监测和日志记录等。4、对聊天室功能进行扩展（如悄悄话功能，表情符号等）。根据以上的功能描述，在仔细分析问题以后我们随便画了画得到下面的草图：




这篇文章中我们要大致实现这个程序的一个基本的核心，包括IChatManager、TChatRoomManager、TchatRoom，完成一个最基本功能的服务器端，并做一个简单的客户端进行检测。我们的重点是服务器端，因为它将实现聊天室的大部分功能，客户端只是一个十分小巧简单的程序。
由于篇幅关系，我们只列出重要的部分的代码，完整的程序请给我发email。首先来看看我们的IchatManager接口是什么样子（由于这里我们只实现了最基本的功能，这个接口并不完整，我们将在以后的文章中给出完整的声明）：

IChatManager = interface(IDispatch)
['{E7CD7F0D-447F-497A-8C7B-1D80E748B67F}']
procedure SpeakTo(const content: WideString; destid: Integer); safecall;
//客户向指定的房间说话，destid为房间号
function ReadFrom(sourceid: Integer): IStrings; safecall;
//客户从指定的房间读取谈话内容，sourceid为房间号
function ReadReady(id: Integer): Byte; safecall;
//客户检测指定的房间是否已经可以读取谈话内容
procedure ConnectRoom(const UserName: WideString; RoomID: Integer); safecall;
//客户登陆指定房间
procedure DisconnectRoom(const UserName: WideString; RoomID: Integer); safecall;
//客户退出指定房间
function TestClearBufferTag(RoomID: Integer): Integer; safecall;
//客户测试指定房间的缓冲区的清空与否状况
end;

再来看看接口的实现类TChatManager部分：

type
TChatManager = class(TAutoObject, IChatManager)
protected
function ReadFrom(sourceid: Integer): IStrings; safecall;
//在这里我们使用Delphi扩展的复杂类型TStings，为了让COM支持这种
//类型，delphi提供了IStrings接口
procedure SpeakTo(const content: WideString; destid: Integer); safecall;
function ReadReady(id: Integer): Byte; safecall;
//用来提供给客户端查询指定的房间是否可读，既指定房间缓冲区是否为空
procedure ConnectRoom(const UserName: WideString; RoomID: Integer);
safecall;
procedure DisconnectRoom(const UserName: WideString; RoomID: Integer);
safecall;
function TestClearBufferTag(RoomID: Integer): Integer; safecall;
end;

实现部分：

function TChatManager.ReadFrom(sourceid: Integer): IStrings;
var
TempRoom:TChatRoom;
begin
TempRoom:=ChatRoomManager.FindRoomByID(sourceid);
while TempRoom.Locked do
begin
//do nothing只是等待解锁
end;
GetOleStrings(TempRoom.OneRead,Result);
end;

procedure TChatManager.SpeakTo(const content: WideString; destid: Integer);
var
TempRoom:TChatRoom;
begin
TempRoom:=ChatRoomManager.FindRoomByID(destid);
while TempRoom.Locked do
begin
//do nothing只是等待解锁
end;
TempRoom.OneSpeak(content);
end;

function TChatManager.ReadReady(id: Integer): Byte;
var
TempRoom:TChatRoom;
begin
TempRoom:=ChatRoomManager.FindRoomByID(id);
if TempRoom.CanRead then result:=1 else Result:=0;
end;

procedure TChatManager.ConnectRoom(const UserName: WideString;
RoomID: Integer);
//客户端通过接口登陆到指定的房间，没有完全实现
var
TempRoom:TChatRoom;
begin
TempRoom:=ChatRoomManager.FindRoomByID(RoomID);
TempRoom.LoginRoom(UserName);
end;

procedure TChatManager.DisconnectRoom(const UserName: WideString;
RoomID: Integer);
//客户端通过接口离开指定的房间，没有完全实现
var
TempRoom:TChatRoom;
begin
TempRoom:=ChatRoomManager.FindRoomByID(RoomID);
TempRoom.LeaveRoom(UserName);
end;

function TChatManager.TestClearBufferTag(RoomID: Integer): Integer;
var
TempRoom:TChatRoom;
begin
TempRoom:=ChatRoomManager.FindRoomByID(RoomID);
result:=TempRoom.ClearBufferTag;
end;

initialization
TAutoObjectFactory.Create(ComServer, TChatManager, Class_ChatManager,
ciMultiInstance, tmApartment);
end.

比较关键TchatRoom是下面的样子：

type
TChatRoom=class
private
FBuffer:array[1..20] of string;
FBufferLength:integer;
FRoomName:string;
FRoomID:integer;
FLocked:boolean;//同步锁，用来处理多人同时发出对话的情况
FConnectCount:integer;//当前房间的人数
FClearBufferTag:integer;
//每清空一次buffer此值便跳变一次，此脉冲被客户端检测
protected
procedure ClearBuffer;//清空缓冲区
function GetCanRead:boolean;
public
constructor Create(RoomName:string;RoomID:integer);
procedure OneSpeak(content:string);//将一条聊天内容加入缓冲区
procedure LoginRoom(UserName:string);//参看实现部分注释
procedure LeaveRoom(UserName:string);//参看实现部分注释
function OneRead:Tstrings;//从缓冲区中读出记录
property Locked:boolean read FLocked; //readonly;//供IChatManager检测
property CanRead:boolean read GetCanRead;//判断缓冲区是否为空，否则是不可读的
property ClearBufferTag:integer read FClearBufferTag;
end;

TchatRoom的实现：

{ TChatRoom }
constructor TChatRoom.Create(RoomName:string;RoomID:integer);
begin
FBufferLength:=0;
FConnectCount:=0;
FClearBufferTag:=1;
FLocked:=false;
FRoomName:=RoomName;
FRoomID:=RoomID;
end;

procedure TChatRoom.ClearBuffer;
var
i:integer;
begin
///在这里可以检测一个标志，判断是否需要服务器记录每一次聊天内容
for i:=1 to 20 do
FBuffer:='';
FBufferLength:=0;
FClearBufferTag:=0-FClearBufferTag;
end;

procedure TChatRoom.OneSpeak(content:string);
begin
FLocked:=true;
inc(FBufferLength);
if FBufferLength>20 then
begin
ClearBuffer;
inc(FBufferLength);
end;
FBuffer[FBufferLength]:=content;
FLocked:=false;
end;

function TChatRoom.OneRead:TStrings;
var
FStrings:TStrings;
i:integer;
begin
FLocked:=true;
FStrings:=TStringList.Create;
for i:=1 to FBufferLength do
FStrings.Add(FBuffer[i]);
result:=FStrings;
FLocked:=false;
end;

function TChatRoom.GetCanRead: boolean;
begin
result:=false;
if FBufferLength>0 then result:=true;
end;

procedure TChatRoom.LoginRoom(UserName:string);
//用户登陆聊天室事件，这里没有完全实现
begin
inc(FConnectCount);
end;

procedure TChatRoom.LeaveRoom(UserName: string);
//用户离开聊天室事件，这里没有完全实现
begin
Dec(FConnectCount);
end;
服务器端的最后一个比较重要的部分TchatRoomManager：
type
TChatRoomManager=class
private
ChatRoom:array of TChatRoom;
public
constructor Create;
function FindRoomByID(id:integer):TChatRoom;
end;

实现部分：

[i]{ TChatRoomManager }

constructor TChatRoomManager.Create;
var
i,RoomCount:integer;
RoomNames:TStrings;//RoomName是配置文件中的聊天室名称
begin
RoomCount:=1;
//这里将从配置文件中读出有几个聊天室
RoomNames:=TStringList.Create;
RoomNames.Add('TestRoom');//这句将被最终的从配置文件读取替换掉
setlength(ChatRoom,RoomCount);
for i:=1 to RoomCount do
ChatRoom[i]:=TChatRoom.Create(RoomNames[i-1],i);
end;

function TChatRoomManager.FindRoomByID(id:integer): TChatRoom;
//该函数由IChatManager接口调用，由于最终版本的接口将会提供给客户
//端得到房间列表的功能，所以客户端知道自己房间的id
begin
result:=ChatRoom[id];
end;

initialization
ChatRoomManager:=TChatRoomManager.Create;
end.

在服务器端的主要核心部分完成以后，我们配置好服务器端的DCOM配置，就可以开发一个简单的客户端进行测试了：（虽然客户端尽可能的简单，我们不用配置DCOM但我们仍需要拷贝服务器端的类型库文件.tlb到客户端并注册后才能开发和使用客户端，当然，这些都可以通过安装程序来完成）

在客户端我们只列出两个相对重要的函数，其余的都省略：

procedure TForm1.Button1Click(Sender: TObject);
//点击button1后将edit的内容“说”出去
begin
Server.SpeakTo(edit1.Text,1);
end;

procedure TForm1.Timer1Timer(Sender: TObject);
//每隔一段时间向服务器请求谈话内容，我设置了为1.5秒
var
TempStrings:TStrings;
i:integer;
begin
if Server.ReadReady(1)=1 then
begin
TempStrings:=TStringList.Create;
SetOleStrings(TempStrings,Server.ReadFrom(1));
if FReadStartPos>19 then
if (FClearBufferTag=0-Server.TestClearBufferTag(1)) then
begin
FReadStartPos:=0;
FClearBufferTag:=Server.TestClearBufferTag(1);
end;
for i:=FReadStartPos to TempStrings.Count-1 do
Memo1.Lines.Add(TempStrings[i]);
FReadStartPos:=TempStrings.Count;
end;
end;

一个基于DCOM的局域网聊天室的核心部分就基本完成了，并且所有的测试都比较顺利，这里需要补充说明一下聊天室服务器的一个难点：就是需要开发者非常谨慎的处理同步，虽然我也进行了一定的同步处理，但在客户端人数众多的情况下仍然可能发生死锁或其它活锁的情况，这个程序还需要更进一步的测试、甚至进行一定的重构。

完善和修补：
基于修正通过测试所发现的bug，和功能的完善，我们有对客户端进行了一定的改动，主要体现在：
·对客户端进行更好的异常处理，以防止由于服务器异常中断而导致客户端仍不端请求服务器所造成的死锁。
·增加了说话对象和悄悄话功能（在客户端实现）
·增加了登录窗体，可以登陆到指定的房间并对服务器进行配置（参看下面服务器的改进）
另外在服务器端我们也做了部分的改进，主要完成了上次没有实现的功能，主要体现在：
·完成了服务器端任意配置并开放多个话题房间的功能（一个TchatRoom的实例对应着一个话题房间）
·在服务器端的每个房间维护一份登录进房间的人员列表，供客户端调用
·完善了服务器端的UI，并在服务器端实现为每个用户的登录和登出进行向客户系统公告的功能，并在服务器端限制登录的人数和进行重名判断
我们来看看主要的改进部分的代码变化情况，首先是服务器端的接口：
IChatManager = interface(IDispatch)
['{E7CD7F0D-447F-497A-8C7B-1D80E748B67F}']
……
function GetRoomList: IStrings; safecall;//客户端获得服务器端的房间列表
function RoomCanLogin(RoomID: Integer; const UserName: WideString): Integer; safecall;
//客户端接收到一个返回值用以判断服务器是否允许客户登录
//返回值的表示：1:可以登陆 2：用户重名 3：人数过多
function RoomUserList(RoomID: Integer): IStrings; safecall;
//供客户端获得在一个房间内的人员列表，由TchatRoom维护这个列表
//每登录和离开一个user便更新列表
end;
其中RoomCanLogin需要的实现比较重要，其余的两个接口只是返回有服务器维护的两个列表而已。
//RoomCanLogin方法对应于TchatRoom类内的实现
function TChatRoom.CanLogin(UserName:string): integer;
var
i:integer;
begin
result:=1;
if FRoomUserList.Count>50 then //最多允许一个房间有50个人
begin
result:=3;
exit;
end;
for i:=0 to FRoomUserList.Count-1 do
//遍历由TchatRoom维护的人员列表以判断是否有重名用户
begin
if FRoomUserList[i]=UserName then
result:=2;
break;
end;
end;
再来看看，上次没有实现的多话题房间维护：
//请对比上篇文章的同名实现
constructor TChatRoomManager.Create;
var
i:integer;
begin
FRoomList:=TStringList.Create;
try
FRoomList.LoadFromFile(ExtractFilePath(application.ExeName)+'ChatRoomList.ini');
except
on E:Exception do
begin
application.MessageBox(Pchar('配置文件错误，错误代码：'+E.Message),'DComChatPro',MB_ICONWARNING);
application.Terminate;
end;
end;
FRoomList.Delete(0);
FRoomCount:=FRoomList.Count;
//这里将从配置文件中读出有几个聊天室
setlength(ChatRoom,FRoomCount);
for i:=1 to FRoomCount do
ChatRoom[i]:=TChatRoom.Create(FRoomList[i-1],i);
//创建房间的每一个实例
end;
客户端的Timer.OnTimer的重要改进（悄悄话和说话对象的功能都在这里实现）：
//请对比上篇文章的同名实现
procedure TClientMainForm.Timer1Timer(Sender: TObject);
var
TempStrings:TStrings;
i:integer;
ToStartPos,ToEndPos:integer;
FromWho,ToWho,TempName:string;
begin
try
if ChatServer.Server.ReadReady(RoomID)=1 then
begin
TempStrings:=TStringList.Create;
SetOleStrings(TempStrings,ChatServer.Server.ReadFrom(RoomID));
if FReadStartPos>19 then
if (FClearBufferTag=0-ChatServer.Server.TestClearBufferTag(RoomID)) then
begin
FReadStartPos:=0;
FClearBufferTag:=ChatServer.Server.TestClearBufferTag(RoomID);
end;
for i:=FReadStartPos to TempStrings.Count-1 do
begin
if RightStr(TempStrings[i],11)='SecretSpeak' then
//可以看到实现悄悄话无非是在说话内容的最后加了一个特殊的标示SecretSpeak
begin
//这一段程序从字符串中解析出说话的对象
ToStartPos:=pos(' 悄悄的对 ',TempStrings[i]);
FromWho:=Copy(TempStrings[i],1,ToStartPos-1);//谁说的
ToStartPos:=ToStartPos+10;
ToEndPos:=pos(' 说：',TempStrings[i]);
ToWho:=Copy(TempStrings[i],ToStartPos,ToEndPos-ToStartPos);//说给谁
////////////////////////////////////////////////////////////////////////////////////////////////////
if (ToWho='所有人') or (ToWho=UserName) or (FromWho=UserName) then
//是自己说的，或自己应该看到的，或是说给所有人的悄悄话都有权看到
begin
Memo1.Lines.Add(Copy(TempStrings[i],1,length(TempStrings[i])-11));
Memo1.Lines.Add('');
end;
end
else //不该看到的内容
begin
Memo1.Lines.Add(TempStrings[i]);
Memo1.Lines.Add('');
end;
end;
FReadStartPos:=TempStrings.Count;
end;
//刷新在线人员列表
Listbox1.Clear;
SetOleStrings(ListBox1.Items,ChatServer.Server.RoomUserList(RoomID));
//刷新说话对象列表
TempName:=SpeakToCBx.Text;
SpeakToCBx.Clear;
SpeakToCBx.Items.Assign(ListBox1.Items);
SpeakToCBx.Items.Insert(0,'所有人');
for i:=0 to SpeakToCBx.Items.Count-1 do
begin
if SpeakToCBx.Items[i]=TempName then Break;
end;
if i>SpeakToCBx.Items.Count-1 then i:=0;
SpeakToCBx.ItemIndex:=i;
//////////////////////////////////////////////////////////////////
except //异常处理
on E:Exception do
begin
Timer1.Enabled:=false;
application.MessageBox
(pchar('通信中断或服务器故障，点确定后将关闭程序，请稍后重启动。详细中断原因：'+E.Message),'DCOMChatClient',MB_ICONWARNING);
application.Terminate;
end;
end;
end;
当然上面的程序所分析的字符串（说给谁，谁说的，是否是悄悄话）都是在speak时产生的，这相当的简单：
//客户端的speak
procedure TClientMainForm.Button1Click(Sender: TObject);
var
content:string;
begin
if Edit1.Text='' then
begin
application.MessageBox('不能发空消息。','DCOMChatClient',MB_ICONINFORMATION);
exit;
end;
if length(edit1.Text)>100 then
begin
application.MessageBox('说话内容过长。','DCOMChatClient',MB_ICONINFORMATION);
exit;
end;
if CheckBox1.Checked then
Content:=UserName+' 悄悄的对 '+SpeakToCBx.Text+' 说：'+edit1.Text+'SecretSpeak'
//可以看到悄悄话功能和说话对象的功能只是在字符串上的简单处理罢了
else
Content:=UserName+' 对 '+SpeakToCBx.Text+' 说：'+edit1.Text;
ChatServer.Server.SpeakTo(Content,RoomID);
edit1.Clear;
end;
至此这个程序已经基本完善了，我们可以打包发布它，以免去最终用户配置DCOM的麻烦。