我仿idtcpdemo做的一个idtcpserver的server端,由于线程很对象以前几乎没有接触过这个概念,所以毛病很多。
程序的主要毛病是,启动之后没问题,然后serveron,然后client连接进来。然后client断开。然后serveroff,然后关闭server程序,但是关闭server程序的时候会出现runtime error,xp系统下,delphi7,然后系统不断的出现那个winxp特有的错误提示信息,问是否要发送到microsoft。server只要不关闭,on 和off都没有问题,on之后client连接断开也都没有问题。
小子是新人,分不太多,达人帮忙看看毛病出在什么地方,谢谢了。主窗体代码如下:
unit frmServerMain;interfaceuses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, IdThreadMgr, IdThreadMgrDefault, IdBaseComponent, IdComponent,
IdTCPServer, StdCtrls,BaseDeclaration;type
TfrmMain = class(TForm)
cmdServerOn: TButton;
server: TIdTCPServer;
IdThreadMgrDefault1: TIdThreadMgrDefault;
cmdServerOff: TButton;
Log: TMemo;
procedure cmdServerOnClick(Sender: TObject);
procedure serverConnect(AThread: TIdPeerThread);
procedure serverExecute(AThread: TIdPeerThread);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure cmdServerOffClick(Sender: TObject);
procedure serverDisconnect(AThread: TIdPeerThread);
private
{ Private declarations }
public
{ Public declarations }
end;
Pclient=^TClient;
TClient=Record
NickName:string[20];
strIP :string[15];
Thread:Pointer;
end;var
frmMain: TfrmMain;
Clients:TThreadlist;
implementation{$R *.dfm}procedure TfrmMain.serverConnect(AThread: TIdPeerThread);
var
NewClient:PClient;
begin
GetMem(NewClient,sizeof(newclient));
NewClient.strIP := athread.Connection.Socket.Binding.PeerIP;
NewClient.Thread:=AThread;
AThread.Data :=TObject(NewClient);
try
Clients.LockList.Add(NewClient);
finally
Clients.UnlockList;
end;
log.Lines.Add('Connected');end;
procedure TfrmMain.serverExecute(AThread: TIdPeerThread);
Var
typDataBlock,typNewDataBLock:TDataBlock;
PCurrentClient,PTargetClient:PClient;
PTargetClientThread:TIdPeerThread;
intCounter:integer;
begin
if not AThread.Terminated and AThread.Connection.Connected then
begin
AThread.Connection.ReadBuffer (typDataBlock,SizeOf(typDataBlock));
PCurrentClient:=PClient(AThread.Data );
if typDataBlock.strCMD ='Login' then
begin
PCurrentclient.strIP :=athread.Connection.Socket.Binding.PeerIP ;
PCurrentclient.NickName :=typDatablock.objMSGSender.strNickName;
Log.Lines.Add(timetostr(now)+'User'+ PCurrentclient.NickName +'Login');
with Clients.LockList do
try
for intCounter := 0 to Count-2 do
begin
PTargetClient := Items[intCounter];
typNewDataBlock.strCMD :='Client';
typNewDataBlock.objMSGSender.strIp :=PTargetClient.strIP ;
typNewDataBlock.objMSGSender.strNickName :=PTargetClient.NickName ;
AThread.Connection.WriteBuffer(typNewDataBlock, SizeOf(typNewDataBlock), True);
end;
finally
Clients.UnlockList;
end;
typNewDataBlock.strCMD :='Login';
typNewDataBlock.objMSGSender.strNickName :=PCurrentClient.NickName ;
typNewDataBlock.objMSGSender.strIp :=PCurrentClient.strIP ;
with Clients.LockList do
try
for intCounter := 0 to Count-2 do
begin
PTargetClient := Items[intCounter];
PTargetClientThread := PTargetClient.Thread;
PTargetClientThread.Connection.WriteBuffer(typNewDataBlock, SizeOf(typNewDataBlock), True);
end;
finally
Clients.UnlockList;
end;
end
else
begin
end;
end;
end;procedure TfrmMain.serverDisconnect(AThread: TIdPeerThread);
var
PCurrentClient,PTargetClient:PClient;
typDataBlock:TDataBlock;
PTargetClientThread:TIdPeerThread;
intCounter:integer;
begin
PCurrentClient:=PClient(AThread.Data );
typDataBlock.strCMD := 'Logoff';
typDataBlock.objMSGSender.strNickName :=PCurrentClient.NickName ;
log.Lines.Add('Disconnected');
try
Clients.LockList.Remove(PCurrentClient);
finally
Clients.UnlockList;
end;
FreeMem(PCurrentClient);
AThread.Data := nil; with Clients.LockList do
begin
if count > 0 then
try
for intCounter := 0 to Count-1 do
begin
PTargetClient := Items[intCounter];
PTargetClientThread := PTargetClient.Thread;
PTargetClientThread.Connection.WriteBuffer(typDataBlock, SizeOf(typDataBlock), True); end;
finally
Clients.UnlockList;
end;
end;
end;
procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
try
if server.Active then
cmdserveroff.Click ;
except
on E:Exception do ;
end;
Clients.Free ;
end;procedure TfrmMain.FormCreate(Sender: TObject);
begin
cmdserveroff.Enabled :=false;
Clients := TThreadList.Create;
end;procedure TfrmMain.cmdServerOnClick(Sender: TObject);beginserver.Active :=True;
cmdServerON.Enabled :=False;
cmdServerOff.Enabled := true;
end;procedure TfrmMain.cmdServerOffClick(Sender: TObject);
var
PTargetClient:PClient;
PTargetClientThread:TIdPeerThread;
intCounter:integer;
begin
cmdServerOn.Enabled :=True;
cmdserveroff.Enabled := false;
with Clients.LockList do
begin
if count > 0 then try
for intCounter := 0 to Count-1 do
begin
PTargetClient := Items[0];
PTargetClientThread := PTargetClient.Thread; PTargetClientThread.Connection.Disconnect; end;
finally
Clients.UnlockList;
end;
end; try
server.Active :=false;
except
on E:Exception do ;
end;end;end.另外还有一个模块:
unit BaseDeclaration;interfaceType
TUser=Record
strIp:string[15];
strNickName:string[20];
end;TDataBlock = Record
strCMD:string[20];
objMSGSender:TUser;
strMSGReceiver:string[20];
strData:string[100];
end;
implementationend.
程序的主要毛病是,启动之后没问题,然后serveron,然后client连接进来。然后client断开。然后serveroff,然后关闭server程序,但是关闭server程序的时候会出现runtime error,xp系统下,delphi7,然后系统不断的出现那个winxp特有的错误提示信息,问是否要发送到microsoft。server只要不关闭,on 和off都没有问题,on之后client连接断开也都没有问题。
小子是新人,分不太多,达人帮忙看看毛病出在什么地方,谢谢了。主窗体代码如下:
unit frmServerMain;interfaceuses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, IdThreadMgr, IdThreadMgrDefault, IdBaseComponent, IdComponent,
IdTCPServer, StdCtrls,BaseDeclaration;type
TfrmMain = class(TForm)
cmdServerOn: TButton;
server: TIdTCPServer;
IdThreadMgrDefault1: TIdThreadMgrDefault;
cmdServerOff: TButton;
Log: TMemo;
procedure cmdServerOnClick(Sender: TObject);
procedure serverConnect(AThread: TIdPeerThread);
procedure serverExecute(AThread: TIdPeerThread);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure cmdServerOffClick(Sender: TObject);
procedure serverDisconnect(AThread: TIdPeerThread);
private
{ Private declarations }
public
{ Public declarations }
end;
Pclient=^TClient;
TClient=Record
NickName:string[20];
strIP :string[15];
Thread:Pointer;
end;var
frmMain: TfrmMain;
Clients:TThreadlist;
implementation{$R *.dfm}procedure TfrmMain.serverConnect(AThread: TIdPeerThread);
var
NewClient:PClient;
begin
GetMem(NewClient,sizeof(newclient));
NewClient.strIP := athread.Connection.Socket.Binding.PeerIP;
NewClient.Thread:=AThread;
AThread.Data :=TObject(NewClient);
try
Clients.LockList.Add(NewClient);
finally
Clients.UnlockList;
end;
log.Lines.Add('Connected');end;
procedure TfrmMain.serverExecute(AThread: TIdPeerThread);
Var
typDataBlock,typNewDataBLock:TDataBlock;
PCurrentClient,PTargetClient:PClient;
PTargetClientThread:TIdPeerThread;
intCounter:integer;
begin
if not AThread.Terminated and AThread.Connection.Connected then
begin
AThread.Connection.ReadBuffer (typDataBlock,SizeOf(typDataBlock));
PCurrentClient:=PClient(AThread.Data );
if typDataBlock.strCMD ='Login' then
begin
PCurrentclient.strIP :=athread.Connection.Socket.Binding.PeerIP ;
PCurrentclient.NickName :=typDatablock.objMSGSender.strNickName;
Log.Lines.Add(timetostr(now)+'User'+ PCurrentclient.NickName +'Login');
with Clients.LockList do
try
for intCounter := 0 to Count-2 do
begin
PTargetClient := Items[intCounter];
typNewDataBlock.strCMD :='Client';
typNewDataBlock.objMSGSender.strIp :=PTargetClient.strIP ;
typNewDataBlock.objMSGSender.strNickName :=PTargetClient.NickName ;
AThread.Connection.WriteBuffer(typNewDataBlock, SizeOf(typNewDataBlock), True);
end;
finally
Clients.UnlockList;
end;
typNewDataBlock.strCMD :='Login';
typNewDataBlock.objMSGSender.strNickName :=PCurrentClient.NickName ;
typNewDataBlock.objMSGSender.strIp :=PCurrentClient.strIP ;
with Clients.LockList do
try
for intCounter := 0 to Count-2 do
begin
PTargetClient := Items[intCounter];
PTargetClientThread := PTargetClient.Thread;
PTargetClientThread.Connection.WriteBuffer(typNewDataBlock, SizeOf(typNewDataBlock), True);
end;
finally
Clients.UnlockList;
end;
end
else
begin
end;
end;
end;procedure TfrmMain.serverDisconnect(AThread: TIdPeerThread);
var
PCurrentClient,PTargetClient:PClient;
typDataBlock:TDataBlock;
PTargetClientThread:TIdPeerThread;
intCounter:integer;
begin
PCurrentClient:=PClient(AThread.Data );
typDataBlock.strCMD := 'Logoff';
typDataBlock.objMSGSender.strNickName :=PCurrentClient.NickName ;
log.Lines.Add('Disconnected');
try
Clients.LockList.Remove(PCurrentClient);
finally
Clients.UnlockList;
end;
FreeMem(PCurrentClient);
AThread.Data := nil; with Clients.LockList do
begin
if count > 0 then
try
for intCounter := 0 to Count-1 do
begin
PTargetClient := Items[intCounter];
PTargetClientThread := PTargetClient.Thread;
PTargetClientThread.Connection.WriteBuffer(typDataBlock, SizeOf(typDataBlock), True); end;
finally
Clients.UnlockList;
end;
end;
end;
procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
try
if server.Active then
cmdserveroff.Click ;
except
on E:Exception do ;
end;
Clients.Free ;
end;procedure TfrmMain.FormCreate(Sender: TObject);
begin
cmdserveroff.Enabled :=false;
Clients := TThreadList.Create;
end;procedure TfrmMain.cmdServerOnClick(Sender: TObject);beginserver.Active :=True;
cmdServerON.Enabled :=False;
cmdServerOff.Enabled := true;
end;procedure TfrmMain.cmdServerOffClick(Sender: TObject);
var
PTargetClient:PClient;
PTargetClientThread:TIdPeerThread;
intCounter:integer;
begin
cmdServerOn.Enabled :=True;
cmdserveroff.Enabled := false;
with Clients.LockList do
begin
if count > 0 then try
for intCounter := 0 to Count-1 do
begin
PTargetClient := Items[0];
PTargetClientThread := PTargetClient.Thread; PTargetClientThread.Connection.Disconnect; end;
finally
Clients.UnlockList;
end;
end; try
server.Active :=false;
except
on E:Exception do ;
end;end;end.另外还有一个模块:
unit BaseDeclaration;interfaceType
TUser=Record
strIp:string[15];
strNickName:string[20];
end;TDataBlock = Record
strCMD:string[20];
objMSGSender:TUser;
strMSGReceiver:string[20];
strData:string[100];
end;
implementationend.
解决方案 »
免费领取超大流量手机卡,每月29元包185G流量+100分钟通话, 中国电信官方发货