(*************************************************************************
* *
* 无所居—服务器端 *
* 版本:1.0 *
* 版权所有(C)无所居 *
* *
*************************************************************************)
unit main;
{*************************************************************************
模块名称:聊天、传文件工具
功能描述:可以多人在局域网内或广域网内聊天、文件的传输
作 者:熊忠国
创建时间:2002/07/02
更新历史:
**************************************************************************}
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ActnList, ScktComp, ExtCtrls, Menus, StdCtrls, ComCtrls,winsock;
type
POnlineinf=^TOnlineinf;
TOnlineinf=record
username:string[255];
soc:Tsocket;
strIP:string;
end;
TfrmMain = class(TForm)
statusb: TStatusBar;
Lonlines: TListBox;
Rtalk: TRichEdit;
MMenu: TMainMenu;
Aoptions: TActionList;
N1: TMenuItem;
N2: TMenuItem;
N3: TMenuItem;
N4: TMenuItem;
N5: TMenuItem;
N6: TMenuItem;
N7: TMenuItem;
N8: TMenuItem;
N9: TMenuItem;
Panel1: TPanel;
ServerS: TServerSocket;
Abeginser: TAction;
Astopser: TAction;
Aexitpro: TAction;
Aparaset: TAction;
Aabout: TAction;
procedure AstopserExecute(Sender: TObject);
procedure AbeginserExecute(Sender: TObject);
procedure ServerSClientRead(Sender: TObject; Socket: TCustomWinSocket);
procedure ServerSClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure LonlinesDblClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure AexitproExecute(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCreate(Sender: TObject);
private
Onlines:Tlist;
{ Private declarations }
public
{ Public declarations }
end;
var
frmMain: TfrmMain;
implementation
const contrallen=16;
{$R *.dfm}
procedure TfrmMain.AstopserExecute(Sender: TObject);
begin
if ServerS.Active then
begin
Servers.Active:= false;
Statusb.SimpleText:='服务已经停止!';
while(Onlines.count<>0) do
begin
dispose(Onlines.First);
onlines.Delete(0);
end;
Lonlines.Clear;
end
else
begin
Messagebox(handle,'服务已停止!','提示',MB_OK);
end;
end;
procedure TfrmMain.AbeginserExecute(Sender: TObject);
begin
if not Servers.Active then
begin
Servers.Active:=true;
statusb.SimpleText:='服务器已激活!';
end
else
begin
Messagebox(handle,'服务器已激活!','提示!',MB_OK);
end;
end;
以下不真的不是很明白啊,浪里白条高手,请指点!我是个新手。
我想利用socket传输信息,信息格式自己定义,比如说
数据长度+数据内容+命令格式等等,然后由接受端分析,根据不同的命令格式来
执行不同的操作等等,我以前用vc做多一点,delphi我刚刚学,我该如何做呢?
请多多指教。
procedure TfrmMain.ServerSClientRead(Sender: TObject;Socket: TCustomWinSocket);
type
nowinfor=(ISININFO,ISOUTINFO,ISTRANSINFO,ISTRANSFILE,INCEPTFILE,REJECTFILE,NONE);
procedure proininfo(inbuf:array of byte;len:integer;s:Tsocket);
var
tempinf
Onlineinf;
templen:integer;
begin
if inbuf[len-1]<>0 then exit;
tempinf:= new(POnlineinf);
templen:= len-contrallen-1;
tempinf.username[0]:=char(lo(templen));
//showmessage(char(lo(templen)));
copymemory(@tempinf.username[1],@inbuf[contrallen],templen);
tempinf.soc:=s;
tempinf.strIP:=socket.RemoteAddress;
onlines.Add(tempinf);
lonlines.Items.Add('用户名:'+tempinf.username+'连接socket:'+inttostr(s));
Lonlines.OnDblClick(Lonlines);
end;
procedure prooutinfo(inbuf:array of byte;len:integer;s:Tsocket);
var
tempinf:TOnlineinf;
templen:integer;
i:integer;
tempcount:integer;
begin
if inbuf[len-1]<>0 then exit;
templen:=len-contrallen-1;
tempinf.username[0]:=char(lo(templen));
copymemory(@tempinf.username[1],@inbuf[contrallen],templen);
tempinf.soc:= s;
tempcount:= onlines.Count-1;
for i:=0 to tempcount do
if (ponlineinf(Onlines.Items
).username=tempinf.username)
and (POnlineinf(onlines.Items).soc= tempinf.soc)
then
begin
dispose(Onlines.Items);
onlines.Delete(i);
break;
end;
tempcount:=Lonlines.Items.Count-1;
for i:= 0 to tempcount do
begin
if ('用户名:'+tempinf.username+'连接socket:'+inttostr(s))=Lonlines.Items
then
begin
Lonlines.Items.Delete(i);
break;
end;
end;
Lonlines.OnDblClick(lonlines);
end;
procedure protransinfo(inbuf:array of byte;len:integer;s:tsocket);
var
i:integer;
sourcename,targetname,talkstr:string;
istransinf:boolean;
idnum:integer;
templen:integer;
basepos:integer;
begin
istransinf:= true;
for i:= 0 to contrallen-1 do
begin
if ((i mod 2 )=0) then istransinf:=istransinf and (inbuf=$F)
else istransinf:= istransinf and (inbuf=$A);
if not istransinf then break;
end;
if not istransinf then
begin
rtalk.Lines.Add('出现不明确的信息包格式,被忽略!');
exit;
end;
for i:= 0 to onlines.Count -1 do
if (ponlineinf(onlines.Items).soc=s) then
begin
sourcename:=POnlineinf(Onlines.Items).username;
break;
end;
if sourcename='' then
sourcename:='某位不知名的聊天者(可能已经下线)';
basepos:=contrallen;
idnum:=Pinteger(@inbuf[basepos])^;
for i:=0 to onlines.count-1 do
begin
if(POnlineinf(onlines.Items).soc=idnum) then
begin
targetname:= POnlineinf(onlines.Items).username;
break;
end;
end;
if targetname='' then
targetname:='某位不知名的聊天者(可能已经下线)';
talkstr:= sourcename+'对'+targetname+'说:';
Pinteger(@inbuf[basepos])^:=s;
inc(basepos,sizeof(integer));
while(basepos<len) and (inbuf[basepos]<>0) do
inc(basepos);
if basepos>=len then
begin
talkstr:='错误的传输流格式,忽略!';
Rtalk.Lines.Add(talkstr);
exit;
end;
templen:=length(talkstr);
setlength(talkstr,templen+basepos-(contrallen+sizeof(integer)));
copymemory
(@talkstr[templen+1],@inbuf[contrallen+sizeof(integer)],basepos-(contrallen+
sizeof(integer)));
rtalk.Lines.Add(talkstr) ;
if (targetname<>'某位不知名的聊天者(可能已经下线)') then
send(idnum,inbuf[0],length(inbuf),0);
end;
procedure protransfile(inbuf:array of byte;len:integer;s:Tsocket);
var
i:integer;
SourceName:string;
TargetName: string;
idnum: integer;
begin
for i:=0 to Onlines.Count -1 do
begin
if(POnlineinf(ONlines.Items).soc=s) then
begin
SourceName:= POnlineinf(Onlines.Items).username;
break;
end;
end;
if SourceName='' then
SourceName:= '某位不知名的聊天者(可能已下线)';
idnum:= Pinteger(@inbuf[contrallen])^;
for i:=0 to Onlines.Count-1 do
begin
if (POnlineinf(Onlines.Items).soc=idnum) then
begin
targetname:= POnlineinf(Onlines.Items).username;
break;
end;
end;
if targetname='' then
targetname:='某位不知名的聊天者(可能已下线)';
Rtalk.Lines.Add(SourceName+'请求向'+targetname+'发送文件');
Pinteger(@inbuf[contrallen])^:= s;
if (targetname<>'某位不知名的聊天者(可能已下线)') then
send(idNum,inbuf[0],length(inbuf),0);
end;
procedure proinceptfile(inbuf:array of byte;len:integer;s:Tsocket);
var
UserId: integer;
TargetName: string;
SourceName: string;
tempstr: string;
i: integer;
begin
UserId:= Pinteger(@inbuf[contrallen])^;
for i:=0 to contrallen-1 do
begin
if POnlineinf(Onlines.Items).soc=UserId then
begin
SourceName:= POnlineinf(Onlines.Items).username;
break;
end;
end;
for I:=0 to contrallen -1 do
begin
if POnlineinf(Onlines.Items).soc=s then
begin
TargetName:= POnlineinf(Onlines.Items).username;
break;
end;
end;
tempstr:=TargetName+'同意接收'+SourceName+'所传送的文件';
Rtalk.Lines.Add(tempstr) ;
send(Userid,inbuf[0],len,0);
end;
procedure prorejectfile(inbuf:array of byte;len:integer;s:Tsocket);
var
UserId: integer;
TargetName: string;
SourceName: string;
tempstr: string;
i: integer;
begin
UserId:= Pinteger(@inbuf[contrallen])^;
for i:=0 to contrallen-1 do
begin
if POnlineinf(Onlines.Items).soc=UserId then
begin
SourceName:= POnlineinf(Onlines.Items).username;
break;
end;
end;
for I:=0 to contrallen -1 do
begin
if POnlineinf(Onlines.Items).soc=s then
begin
TargetName:= POnlineinf(Onlines.Items).username;
break;
end;
end;
tempstr:=TargetName+'不同意接收'+SourceName+'所传送的文件';
Rtalk.Lines.Add(tempstr) ;
send(Userid,inbuf[0],len,0);
end;
var
buf:array of byte;
len:integer;
i:integer;
tag:nowinfor;
nowtag:boolean;
begin
len:=socket.ReceiveLength;
setlength(buf,len);
socket.ReceiveBuf(buf[0],len) ;
if len<contrallen then exit;
nowtag:=true;
for i:=0 to contrallen -1 do
begin
if ((i mod 2)=0 )then nowtag:=nowtag and (buf=$E)
else nowtag:=nowtag and (buf=$A);
if not nowtag then break;
end;
if nowtag then tag:=ISININFO
else
begin
nowtag:= true;
for i:=0 to contrallen-1 do
begin
if ((i mod 2) =0)then
nowtag:=nowtag and (buf=$A)
else nowtag:=nowtag and (buf=$E);
if not nowtag then break;
end;
if nowtag then tag:=ISOUTINFO
else
begin
nowtag:=true;
for i:=0 to contrallen-1 do
begin
if ((i mod 2)=0 ) then
nowtag := nowtag and (buf=$F)
else nowtag:= nowtag and (buf=$A);
if not nowtag then break;
end;
if nowtag then tag:=ISTRANSINFO else
begin
nowtag:= true;
for i:=0 to contrallen-1 do
begin
if ((i mod 2)=0) then nowtag:=nowtag and (buf=$C)
else nowtag:=nowtag and (buf=$D);
if not nowtag then break;
end;
end ;
if nowtag then tag:=ISTRANSFILE else
begin
nowtag:= true;
for i:=0 to contrallen-1 do
begin
if ((i mod 2)=0) then nowtag:=nowtag and (buf=$D)
else nowtag:=nowtag and (buf=$C);
if not nowtag then break;
end;
if nowtag then tag:=INCEPTFILE else
begin
nowtag:= true;
for i:=0 to contrallen-1 do
begin
if ((i mod 2)=0) then nowtag:=nowtag and (buf=$B)
else nowtag:=nowtag and (buf=$A);
if not nowtag then break;
end;
if nowtag then tag:=REJECTFILE else
tag:= NONE;
end;
end;
end;
end;
case tag of
ISININFOroininfo(buf,len,socket.sockethandle);
ISOUTINFOrooutinfo(buf,len,socket.SocketHandle);
ISTRANSINFOrotransinfo(buf,len,socket.SocketHandle);
ISTRANSFILErotransfile(buf,len,socket.SocketHandle);
INCEPTFILEroinceptfile(buf,len,socket.sockethandle);
REJECTFILErorejectfile(buf,len,socket.SocketHandle);
NONE:Rtalk.Lines.Add('出现不明确的信息包格式,被忽略!') ;
end;
end;
procedure TfrmMain.ServerSClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
var
i:integer;
temstr:string;
tempcount:integer;
begin
tempcount:= onlines.Count-1;
for i:= 0 to tempcount do
begin
if (POnlineinf(onlines.Items).soc=socket.SocketHandle) then
begin
dispose(onlines.items);
onlines.Delete(i);
break;
end;
end;
temstr:='连接socket:'+inttostr(socket.sockethandle);
tempcount:=Lonlines.Items.Count-1 ;
for i:=0 to tempcount do
begin
if pos(temstr,Lonlines.items)<>0 then
begin
Lonlines.Items.Delete(i);
break;
end;
end;
Lonlines.OnDblClick(Lonlines);
end;
procedure TfrmMain.LonlinesDblClick(Sender: TObject);
var
I:integer;
templen,len:integer;
buf:array of byte;
lenIP:integer;
tempIP:string;
tempUsername:string;
begin
setlength(buf,contrallen+sizeof(integer));
for i:= 0 to contrallen-1 do
if ((i mod 2)=0 ) then buf:=$A
else buf:=$F;
Pinteger(@buf[contrallen])^:=Onlines.Count;
for i:=0 to onlines.count-1 do
begin
tempUsername:=POnlineinf(Onlines.Items).username;
len:=length(tempUsername);
templen:=length(buf);
tempIP:=POnlineinf(Onlines.Items).strIP;
lenIP:= length(tempIP);
setlength(buf,templen+sizeof(integer)+len+sizeof(integer)+sizeof(integer)+lenIP);
Pinteger(@buf[templen])^:=len;
copymemory(@buf[templen+sizeof(integer)],@tempUsername[1],len);
Pinteger(@buf[templen+sizeof(integer)+len])^:=POnlineinf(onlines.Items).soc;
Pinteger(@buf[templen+sizeof(integer)+len+sizeof(integer)])^:=lenIP;
copymemory(@buf[templen+sizeof(integer)+len+sizeof(integer)+sizeof(integer)],
@tempIP[1],lenIP);
end;
len:=length(buf);
for i:= 0 to onlines.Count-1 do
send(POnlineinf(onlines.Items).soc,buf[0],len,0);
end;
procedure TfrmMain.FormDestroy(Sender: TObject);
begin
while (onlines.count>0) do
begin
dispose(onlines.first);
onlines.Delete(0);
end;
onlines.Free;
end;
procedure TfrmMain.AexitproExecute(Sender: TObject);
begin
close;
end;
procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if ServerS.Active then
servers.Active:= false;
end;
procedure TfrmMain.FormCreate(Sender: TObject);
begin
onlines:=tlist.Create;
end;
end.