Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Форум: "Сети";
Текущий архив: 2010.08.27;
Скачать: [xml.tar.bz2];

Вниз

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

 
+koha   (2008-08-22 12:49) [0]

Прошу модераторов не банить ветку как эту http://delphimaster.net/view/6-1218807638/.
Просто перед хотел фраернуться перед кентами. Ну, вот скажите зачем трою нужен сервер да еще и мульти поточный? глупость.
Увидел мини веб-сервер размером 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 12:56) [1]

Конечно приводит.
И именно в приведенном коде.

Ты объект-поток создал ? Создал.
Хэндл объекта-потока получил ? Получил.
А уничтожать этот объект - закрывать полученный при создании хэндл - кто за тебя будет, Пушкин ?


 
Сергей М. ©   (2008-08-22 13:01) [2]


> на чистом API


Какой же это "чистый API" ?
Ты же SysUtils используешь, значит уже испачкался)


> Хочу опровергнуть это Делфа нихрена не хуже.


Поздравляю, ты открыл Америку)


 
+koha   (2008-08-22 13:06) [3]


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


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


 
+koha   (2008-08-22 13:12) [4]

> А уничтожать этот объект - закрывать полученный при создании хэндл - кто за > тебя будет, Пушкин ?

Хедлы потоков-клиентов закрывать будет поток TCPThreadProc по полученным PostThreadMessage(hTCPThread, NET_MESSAGE, Integer(TC_STOP_CLIENT), PClientInfo(Param).ClientSocket) от клиентов сообщениям или самостоятельно при своем завершении. Просто код не влазит в размер 7168 бт. так на форуме определено, я код допишу и покажу.


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


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


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

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

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

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


> PeekMessage(Msg,hTCPThread


> PostThreadMessage(hTCPThread


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


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

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

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:30) [7]


> if Command = "CLOSE_SESSION" then


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


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


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


Нибуть есть.

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

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

2.


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


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

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

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


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


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


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


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


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


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

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


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


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


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


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


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


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

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


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


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


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


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


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


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


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


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


Не, не сижу)

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


 
Anatoly Podgoretsky ©   (2008-08-22 14:14) [16]

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

(Num < 0) or (Num > Count)

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


 
DVM ©   (2008-08-22 16:30) [17]


> +koha   (22.08.08 12:49)


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

Наш ответ tinyweb:

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

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


 
DVM ©   (2008-08-22 16:31) [18]


> Наш ответ tinyweb:

57 кб exe файл.


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


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


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


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


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


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

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


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


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


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


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


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


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


> не имею


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


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


> достало


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


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


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


> бухать


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

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


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


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

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


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


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


Я слышал, конечно же, что у людей с неустойчивой психикой, по крайней мере весной и осенью, бывают обострения или слишком весна затянулась или осень рано началась, что на вас влияет больше? Я такого не видывал, что бы от пару слов каких то и даже не ругательных человек приходил в такую жуткую взвинченность. В одном посте ваш "базар" уже удалили http://delphimaster.net/view/6-1218807638/  но вы как вы думаете такой рьяный борец за чистоту разговора на самом деле ни сколько того не лучше. Я бы от модераторов еще потребовал, чтобы и этот пост удалили  Сергей М. ©   (22.08.08 21:52) [22]   Так как это не по теме, и к тому же оскорбляет.


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


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


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

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



Страницы: 1 вся ветка

Форум: "Сети";
Текущий архив: 2010.08.27;
Скачать: [xml.tar.bz2];

Наверх




Память: 0.6 MB
Время: 0.057 c
2-1273081388
SooM
2010-05-05 21:43
2010.08.27
Работа с текстом(перевёртыш)


2-1262612569
ZV
2010-01-04 16:42
2010.08.27
Компонент TMS Async 32 (СОМ порт) ,объясните как с ним работать


2-1268379582
timekiller
2010-03-12 10:39
2010.08.27
ProgreessBar, подвисание проги


2-1265831068
сало-масло-колбаса
2010-02-10 22:44
2010.08.27
Как отобразить не свызанные записи в таблице


2-1274084890
REX
2010-05-17 12:28
2010.08.27
метод ExecSQL (компонент ADOQuery)





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский