Top.Mail.Ru
Мастера DELPHI, Delphi programming community Титульная страница Поиск, карта сайта Написать письмо 
| Новости | Поиск | FAQ | Статьи | Книги | Новости VCL |
| Форумы ЧАТ | Орешник | KOL и MCK |
Форумы -» Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG

« предыдущая ветвь | форум | следующая ветвь »

Многопоточный сервер на чистом API


Страницы:   1 2

+koha ©   (2008-08-22 12:49:00) 

Прошу модераторов не банить ветку как эту http://www.delphimaster.ru/cgi-bin/forum.pl?id=1218807638&n=4.
Просто перед хотел фраернуться перед кентами. Ну, вот скажите зачем трою нужен сервер да еще и мульти поточный? глупость.
Увидел мини веб-сервер размером 10кб. http://miniwebsvr.sourceforge.netрешил что-нибудь подобное сотворить на Delphi, а то говорят, что на нем такие миниатюрные вещи нельзя сотворить, ну типа нужен только СИ. Хочу опровергнуть это Делфа нихрена не хуже.

Немного усовершенствовал код, но все же будет вопрос:
Действительно ли вызов функции BeginThread() в Delphi приводит к утечке памяти?
И в этом приведенном коде она возможна?
Ну може кто еще чего подскажет?

unit TCP;

interface
Uses Windows, SysUtils, WinSock, SockErr, MsgLog;

Type
  PClientInfo = ^TClientInfo;
  TClientInfo = Record
    ClientSocket : TSocket;
    ClientAddr   : sockaddr_in;
    hClientThr   : THandle;
    ClientThrId  : Integer;
  end;

Type TThrCmd = (TC_READ, TC_WRITE, TC_STOP_SERVER, TC_STOP_CLIENT, TC_ERROR);

Function StartTCPServer(Port: Integer): Boolean;
Function StopTCPServer: Boolean;
Procedure TCPThreadProc(Param: Pointer);
Procedure TCPClientThreadProc(Param: Pointer);
Procedure AcceptProc(Param: Pointer);

Var
 hTCPThread  : Thandle;
 TCPThreadId : LongWord;
 WData       : TWSAData;
 SockListen  : TSocket;
 LocalAddr   : sockaddr_in;
 hAcceptThr  : THandle;
 AcceptThrId : LongWord;
 ClientInfoArray  : array of PClientInfo;
 MultipleThrArray : Array[1..MAXIMUM_WAIT_OBJECTS] of Thandle;
 CS_REC           : TRTLCriticalSection;

Const
 WM_NULL = $0000;
 WM_APP  = $8000;
 PM_NOREMOVE = 0;
 NET_MESSAGE = WM_USER+1;

implementation

function DeleteClientInfo(Num: integer): Integer;
var
 Count: integer;
begin
 try
   EnterCriticalSection(CS_REC);
   Count := length(ClientInfoArray);
   if (Num < 0) or (Num > Count) then Exit;
   Dispose(ClientInfoArray[num]);
   System.Move(ClientInfoArray[num+1],ClientInfoArray[num],(Count-num)*SizeOf(Pointer));
   SetLength(ClientInfoArray, Pred(Num));
 finally
   LeaveCriticalSection(CS_REC);
 end;
end;

Function StartTCPServer(Port: Integer): Boolean;
Var
 Err: Integer;
begin
 Result := True;
 if Not WSAStartup(MakeWord(1,1),WData) = 0 then begin
   SendDebugMsg('Err: (WSAStartup 0) WSAGetLastError: '+SockErrToStr(WSAGetLastError));
   Result := false;
   Exit;
 end;
 SockListen := Socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
 if SockListen = INVALID_SOCKET then begin
   SendDebugMsg('Error: Socket > WSAGetLastError: '+SockErrToStr(WSAGetLastError));
   Result := false;
   Exit;
 end;
 LocalAddr.sin_addr.S_addr := htonl(INADDR_ANY);
 LocalAddr.sin_family      := AF_INET;
 LocalAddr.sin_port        := htons(Port);
 if bind(SockListen, LocalAddr, sizeOf(LocalAddr)) = SOCKET_ERROR then begin
   SendDebugMsg('bind() Error: '+SockErrToStr(WSAGetLastError));
   Result := false;
   Exit;
 end;
 if Listen(SockListen,MAXIMUM_WAIT_OBJECTS) = SOCKET_ERROR then begin
   SendDebugMsg('Listen() Error: ' + SockErrToStr(WSAGetLastError));
   Result := false;
   Exit;
 end;
 hTCPThread := BeginThread(Nil,0, Addr(TCPThreadProc), 0,0, TCPThreadId);
 if hTCPThread = 0 then begin
   SendDebugMsg('Error: hTCPThread = 0 GLE: '+IntToStr(GetLastError));
   Result := False;
   Exit;
 end;
end;

Function StopTCPServer: Boolean;
begin
 Result:=false;
 if hTCPThread = Nil then Exit;
 PostThreadMessage(hTCPThread,NET_MESSAGE,integer(TC_STOP_SERVER),0);
 //Пока Без доп. проверки действительно ли остановился сервер или вышел таймаут
 while WaitForSingleObject(hTCPThread,600000) = WAIT_TIMEOUT do begin
   Sleep(50);
 end;
 Result:=True;
end;

Procedure TCPThreadProc(Param: Pointer);
Var
 Msg: TMsg;
begin
 try
   InitializeCriticalSection(CS_REC);
   hAcceptThr:=BeginThread(Nil,0,Addr(AcceptProc),Pointer(SockListen),0,AcceptThrId );
   if hAcceptThr = 0 then begin
     SendDebugMsg('Error: (hProc = 0) GLE: '+IntToStr(GetLastError));
     Exit;
   end;
   While true do begin
     if PeekMessage(Msg,hTCPThread, WM_NULL, WM_APP, PM_NOREMOVE) then begin
       GetMessage(Msg, 0, 0, 0);
       DispatchMessage(msg);
       Case TThrCmd(MSG.wParam) of
         TC_WRITE       : SendDebugMsg('MSG.wParam = TC_WRITE');
         TC_STOP_SERVER : SendDebugMsg('MSG.wParam = TC_STOP_SERVER');
         TC_STOP_CLIENT : SendDebugMsg('MSG.wParam = TC_STOP_CLIENT');
         TC_ERROR       : SendDebugMsg('MSG.wParam = TC_ERROR');
       end;
     end;
     Sleep(50);
   end;  
 finally
   DeleteCriticalSection(CS_REC);
 end;
end;

Procedure TCPClientThreadProc(Param: Pointer);
Var
 Err        : Integer;
 Buff       : Array[1..1024] of Char;
 Command    : String;
begin
 While True do begin
   FillChar(Buff, 1024, 0);
   Err := Recv(PClientInfo(Param).ClientSocket, Buff, 1024, 0);
   if Err = SOCKET_ERROR then begin
     SendDebugMsg(IntToStr(PClientInfo(Param).ClientThrId)
                  +' Err: TCPClientThreadProc Recv = '+SockErrToStr(WSAGetLastError));
     PostThreadMessage(TCPThreadId, NET_MESSAGE, Integer(TC_ERROR),PClientInfo(Param)^.ClientThrId);
     Exit;
   end;
   Command := StrPas(PChar(@Buff));
   if Command = '' then  begin
     CloseSocket(PClientInfo(Param)^.ClientSocket);
     Exit;
   end;
   SendDebugMsg('ComStr = '+Command+' '+IntToStr(Length(Command)));
   {=================================
     Command section                
    =================================}
   if Command = 'CLOSE_SESSION' then
     PostThreadMessage(hTCPThread, NET_MESSAGE, Integer(TC_STOP_CLIENT), PClientInfo(Param).ClientSocket);
 end;
end;

Procedure AcceptProc(Param: Pointer);
Var
 Size        : Integer;
 ClientThrId : Cardinal;
 hClientThr  : THandle;
 ClientAddr  : SockAddr_in;
 ClientInfo  : PClientInfo;
 Num         : Integer;
begin
 While True do begin
   New(ClientInfo);
   FillChar(ClientInfo^,SizeOf(TClientInfo), 0);
   Size := SizeOf(ClientAddr);
   ClientInfo.ClientSocket := accept(TSocket(Param),@ClientAddr, @Size);
   if ClientInfo.ClientSocket = INVALID_SOCKET then begin
     SendDebugMsg('Err: accept WSA_GLE: '+SockErrToStr(WSAGetLastError));
     PostThreadMessage(TCPThreadId,NET_MESSAGE,Integer(TC_ERROR),0);
     CloseSocket(ClientInfo.ClientSocket);
     Dispose(ClientInfo);
     Continue;
   end;
   try
     EnterCriticalSection(CS_REC);
     Num := Length(ClientInfoArray);
     SetLength(ClientInfoArray, Num+1);
     ClientInfo.ClientAddr := ClientAddr;    
     hClientThr := BeginThread(Nil,0,Addr(TCPClientThreadProc),ClientInfoArray[Num],CREATE_SUSPENDE D,ClientThrId);
     if hClientThr = 0 then begin
       SendDebugMsg('BeginThread err:'+IntToStr(GetLastError));
       CloseSocket(ClientInfo^.ClientSocket);
       Dispose(ClientInfo);
       SetLength(ClientInfoArray, num);
       Continue;
     end;
     ClientInfo.hClientThr  := hClientThr;
     ClientInfo.ClientThrId := ClientThrId;
     ClientInfoArray[Num]   := ClientInfo;
     ResumeThread(ClientInfo.hClientThr);
   finally
     LeaveCriticalSection(CS_REC);
   end;
 end;
end;

end.

Сергей М.   (2008-08-22 22:47:00) [1]


> +koha   (22.08.08 22:15) [23]


Помощь нужна тебе?

Ты это уже забыл, психоустойчивый ты наш "фраер" ?)

+koha   (2008-08-22 22:15:00) [2]


> Сергей М. ©   (22.08.08 21:52) [22]


Я слышал, конечно же, что у людей с неустойчивой психикой, по крайней мере весной и осенью, бывают обострения или слишком весна затянулась или осень рано началась, что на вас влияет больше? Я такого не видывал, что бы от пару слов каких то и даже не ругательных человек приходил в такую жуткую взвинченность. В одном посте ваш "базар" уже удалили http://www.delphimaster.ru/cgi-bin/forum.pl?id=1219419409&n=3 но вы как вы думаете такой рьяный борец за чистоту разговора на самом деле ни сколько того не лучше. Я бы от модераторов еще потребовал, чтобы и этот пост удалили   Сергей М. ©   (22.08.08 21:52) [22]  Так как это не по теме, и к тому же оскорбляет.

Сергей М.   (2008-08-22 21:52:00) [3]


> малограмотный


> не "кинчивал"


> не имею


> по народному


> детство трудное


> достало


> мало грамотен я и сам


> жил в моем дворе


> пьют да дерутся


> бухать


Ты сюда хныкать явился, да ?

Меж прочим, никто тебя за "фраерский" язык не тянул.


> Не убивайте во мне последнюю надежду


Никто ее в тебе не убивает.

Просто заканчивай сраное дворовое полууголовное детство)

+koha   (2008-08-22 21:35:00) [4]


> Сергей М. ©   (22.08.08 20:48) [20]


А что вы от меня ожидали? Что вам не понравилось слово "протащился"?  Да, я малограмотный, институтов не "кинчивал" степеней не имею, говорю по народному, вас это смущает? Ну извините детство трудное было. Вот это меня тоже достало когда постоянно тыкают, что мало грамотен я и сам об этом знаю. Так вот скажу все кто жил в моем дворе из мох ровестников все давно испились или половину сидят и уже не вылезут из этого никогда, район наш весь разломали половина домов сгорела вообще и сталось их чуть беле десятка, и народ в них в основном пьют да дерутся, так вот я еще более менее держусь хоть чем то занимаюсь у меня интересы есть в программировании это хобби у меня, а мог бы махнуть рукой и беспробудно бухать как все и превратиться в очередного "древолоса" или стать полным быдлом. Не убивайте во мне последнюю надежду.

Сергей М.   (2008-08-22 20:48:00) [5]


> +koha   (22.08.08 20:30) [19]


Как был ты "протащилкиным", так ты в местной памяти и останешься - "потащившимся фраером")

В след.раз, дитятко, "следи за базаром".

+koha   (2008-08-22 20:30:00) [6]


> DVM ©   (22.08.08 16:30) [17]


Да "протащился" вполне от увиденного, штука классная, еще и исходники впридачу.

DVM   (2008-08-22 16:31:00) [7]


> Наш ответ tinyweb:

57 кб exe файл.

DVM   (2008-08-22 16:30:00) [8]


> +koha   (22.08.08 12:49)


> Увидел мини веб-сервер размером 10кб. http://miniwebsvr.
> sourceforge.net решил что-нибудь подобное сотворить на Delphi

Наш ответ tinyweb:

http://www.ritlabs.com/en/products/tinyweb/

Кстати, на делфи.

Anatoly Podgoretsky   (2008-08-22 14:14:00) [9]

> +koha  (22.08.2008 13:30:06)  [6]

(Num < 0) or (Num > Count)

А это что за муть?

Сергей М.   (2008-08-22 14:06:00) [10]


> +koha   (22.08.08 14:01) [13]


Не, не сижу)

А что, у тебя терапевты логин отобрали разве ?
По-моему только ветку забанили ..

+koha   (2008-08-22 14:03:00) [11]


> Сергей М. ©   (22.08.08 13:24) [5]Упаришься перетягивать)Поковыряешься-
> попаришься со своей собственной SEH-оболочкой, плюнешь на
> это гнилое дело и повернешь оглобли назад в сторону Exception-
> объекта)


Ничего наше дело молодое, зато многое в голове осядет.

+koha   (2008-08-22 14:01:00) [12]


> Сергей М. ©   (22.08.08 13:53) [12]


а вы с терапевтам рядом не сидите случаем или около того, а то может передали бы мою просьбу :-)

Сергей М.   (2008-08-22 13:53:00) [13]


> можно как-нибуть свой логин вернуть


Нибуть можно.

Но это не ко мне, а к терапевту)

+koha   (2008-08-22 13:51:00) [14]


> Сергей М. ©   (22.08.08 13:39) [8]что твои мув-эксперименты
> не имеют отношения к забаненой ветке, где ты "фраерился"
> про "нового троянца"


Да потому, что тема, ни та ни эта ничего общего с "троянцами" не имеет. ее так забанили за сам факт этого слова, как я думаю, за что извиняюсь, глупо поступил.  А можно как-нибуть свой логин вернуть, это я так меж делом спрашиваю, а то задолбался писать с приставками +-_ свой логин

Сергей М.   (2008-08-22 13:45:00) [15]


> +koha   (22.08.08 13:42) [9]


Что и через кого ты там будешь "пропускать" - это ты сам решай.

Правило одно : получил новый хэндл объекта (неважно какого) ? Изволь по окончании работы с объектом закрыть этот хэндл !

+koha   (2008-08-22 13:42:00) [16]


> +koha   (22.08.08 13:30) [6]


ClientInfoArray[num] Содержит нэдл потока и сокет, наверное предварительно нужно пропустить через Closehandle СloseSocket? А если уже поток остановился сокет = ERROR_SOCKET все равно их нужно пропустить через Closehandle СloseSocket?

Сергей М.   (2008-08-22 13:39:00) [17]


> Есть ли тут какие-нибуть нарекания?


Нибуть есть.

И довольно серьезные.

1. Неверная логика использования защитного try-блока.

2.


> System.Move(ClientInfoArray[num+1],ClientInfoArray[num],
> (Count-num)*SizeOf(Pointer));


Пусть в массиве Count = 3 элемента.
Пусть ты удаляешь средний (Num=1) элемент.
Тогда мувом ты должен перенести один элемент, а ты почему-то переносишь 2 элемента (Count - Num = 2)

Кстати, и что же ты, "фраер", парил мозги "кентам", что твои мув-эксперименты не имеют отношения к забаненой ветке, где ты "фраерился" про "нового троянца" ?

Ай как некузяво получается)

Сергей М.   (2008-08-22 13:30:00) [18]


> if Command = 'CLOSE_SESSION' then


Это тоже работать не обязано.

+koha   (2008-08-22 13:30:00) [19]

Меня вот еще это интересует. Есть ли тут какие-нибуть нарекания?

function DeleteClientInfo(Num: integer): Integer;
var
Count: integer;
begin
try
  EnterCriticalSection(CS_REC);
  Count := length(ClientInfoArray);
  if (Num < 0) or (Num > Count) then Exit;
  Dispose(ClientInfoArray[num]);
  System.Move(ClientInfoArray[num+1],ClientInfoArray[num],(Count-num)*SizeOf(Pointer));
  SetLength(ClientInfoArray, Pred(Num));
finally
  LeaveCriticalSection(CS_REC);
end;
end;

Сергей М.   (2008-08-22 13:24:00) [20]


> некоторые его функции перетяну в отдельный модуль или заменю
> на API


Упаришься перетягивать)

На нем завязан объект Exception.

Поковыряешься-попаришься со своей собственной SEH-оболочкой, плюнешь на это гнилое дело и повернешь оглобли назад в сторону Exception-объекта)

Ну и собссно по теме - еще одна утечка у тебя в ClientInfoArray, потому как простые указательные типы не являются типами с управляемым компилятором временем жизни.


> PeekMessage(Msg, hTCPThread


> PostThreadMessage( hTCPThread


Это работать не будет.

Страницы:   1 2

Наверх

Титульная страница Поиск, карта сайта Написать письмо