Прошу модераторов не банить ветку как эту
http://pda.delphimaster.net/?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.
Есть новые 
Нет новых [134432 +20][b:0][p:0.001]