Delphi控件源码

开发平台：

WINDOWS

WSOCKET.PAS：源码内容

bMore := FALSE;
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.WMASyncSelect(var msg: TMessage);
var
Check : Word;
begin
{TriggerDisplay('AsyncSelect ' + IntToStr(msg.wParam) + ', ' + IntToStr(msg.lParamLo));}
{ Verify that the socket handle is ours handle }
if msg.wParam <> FHSocket then
Exit;
if FPaused then
exit;
Check := msg.lParamLo and FD_CONNECT;
if Check <> 0 then begin
ChangeState(wsConnected);
TriggerSessionConnected(msg.lParamHi);
if (msg.lParamHi <> 0) and (FState <> wsClosed) then
Close;
end;
Check := msg.lParamLo and FD_READ;
if Check <> 0 then begin
ASyncReceive(msg.lParamHi);
end;
Check := msg.lParamLo and FD_WRITE;
if Check <> 0 then begin
TryToSend;
{ If you wants to test background exception, uncomment the next 2 lines. }
{ if bAllSent then }
{ raise Exception.Create('Test TWSocket exception'); }
if bAllSent then
TriggerDataSent(msg.lParamHi);
end;
Check := msg.lParamLo and FD_ACCEPT;
if Check <> 0 then begin
TriggerSessionAvailable(msg.lParamHi);
end;
Check := msg.lParamLo and FD_CLOSE;
if Check <> 0 then begin
{* In some strange situations I found that we receive a FD_CLOSE *}
{* during the connection phase, breaking the connection early ! *}
{* This occurs for example after a failed FTP transfert *}
if FState <> wsConnecting then begin
{* Check if we have something arrived, if yes, process it *}
ASyncReceive(0);
if Assigned(FOnSessionClosed) and (not FCloseInvoked) then begin
FCloseInvoked := TRUE;
TriggerSessionClosed(msg.lParamHi);
end;
if FState <> wsClosed then
Close;
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure GetIPList(phe : PHostEnt; ToList : TStrings);
type
TaPInAddr = array [0..255] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
pptr : PaPInAddr;
I : Integer;
begin
pptr := PaPInAddr(Phe^.h_addr_list);
I := 0;
while pptr^[I] <> nil do begin
ToList.Add(StrPas(WSocket_inet_ntoa(pptr^[I]^)));
Inc(I);
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.WMAsyncGetHostByName(var msg: TMessage);
var
Phe : Phostent;
Error : Word;
begin
if msg.wParam <> LongInt(FDnsLookupHandle) then
Exit;
FDnsLookupHandle := 0;
Error := Msg.LParamHi;
if Error = 0 then begin
Phe := PHostent(@FDnsLookupBuffer);
if phe <> nil then begin
GetIpList(Phe, FDnsResultList);
FDnsResult := FDnsResultList.Strings[0];
end;
end;
TriggerDnsLookupDone(Error);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.WMAsyncGetHostByAddr(var msg: TMessage);
var
Phe : Phostent;
Error : Word;
begin
if msg.wParam <> LongInt(FDnsLookupHandle) then
Exit;
FDnsLookupHandle := 0;
Error := Msg.LParamHi;
if Error = 0 then begin
Phe := PHostent(@FDnsLookupBuffer);
if phe <> nil then begin
SetLength(FDnsResult, StrLen(Phe^.h_name));
StrCopy(@FDnsResult[1], Phe^.h_name);
FDnsResultList.Clear;
FDnsResultList.Add(FDnsResult);
end;
end;
TriggerDnsLookupDone(Error);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.SetProto(sProto : String);
begin
if FProtoAssigned and (sProto = FProtoStr) then
Exit;
if FState <> wsClosed then begin
RaiseException('Cannot change Proto if not closed');
Exit;
end;
FProtoStr := Trim(sProto);
if Length(FProtoStr) = 0 then begin
FProtoAssigned := FALSE;
Exit;
end;
FProtoResolved := FALSE;
FProtoAssigned := TRUE;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomWSocket.GetProto : String;
begin
Result := FProtoStr;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.SetRemotePort(sPort : String);
begin
if FPortAssigned and (FPortStr = sPort) then
Exit;
if FState <> wsClosed then begin
RaiseException('Cannot change Port if not closed');
Exit;
end;
FPortStr := Trim(sPort);
if Length(FPortStr) = 0 then begin
FPortAssigned := FALSE;
Exit;
end;
FPortResolved := FALSE;
FPortAssigned := TRUE;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomWSocket.GetRemotePort : String;
begin
Result := FPortStr;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.SetLocalPort(sLocalPort : String);
begin
if FState <> wsClosed then begin
RaiseException('Cannot change LocalPort if not closed');
Exit;
end;
FLocalPortStr := sLocalPort;
FLocalPortResolved := FALSE;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomWSocket.GetXPort: string;
var
saddr : TSockAddrIn;
saddrlen : integer;
port : integer;
begin
Result := 'error';
if FState in [wsConnected, wsBound, wsListening] then begin
saddrlen := sizeof(saddr);
if WSocket_GetSockName(FHSocket, TSockAddr(saddr), saddrlen) = 0 then begin
port := WSocket_ntohs(saddr.sin_port);
Result := Format('%d',[port]);
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.SetAddr(InAddr : String);
begin
if FAddrAssigned and (FAddrStr = InAddr) then
Exit;
if FState <> wsClosed then begin
RaiseException('Cannot change Addr if not closed');
Exit;
end;
FAddrStr := Trim(InAddr);
if Length(FAddrStr) = 0 then begin
FAddrAssigned := FALSE;
Exit;
end;
FAddrResolved := FALSE;
FAddrAssigned := TRUE;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocketResolveHost(InAddr : String) : TInAddr;
var
szData : array [0..256] of char;
Phe : Phostent;
IPAddr : u_long;
begin
if (Length(InAddr) = 0) or (Length(InAddr) >= SizeOf(szData)) then
raise ESocketException.Create('WSocketResolveHost: ''' + InAddr + ''' Invalid Hostname.');
StrPCopy(szData, Trim(InAddr));
{ if not DllStarted then
LoadWinsock(WINSOCKET); 14/02/99 }
if IsDigit(szData[0]) then begin
{ Address is a dotted numeric address like 192.161.124.32 }
IPAddr := WSocket_inet_addr(szData);
{$IFDEF VER80}
{ With Trumpet Winsock 2B and 30D (win 3.11), inet_addr returns faulty }
{ results for 0.0.0.0 }
if (IPAddr = INADDR_NONE) and (StrComp(szData, '0.0.0.0') = 0) then begin
Result.s_addr := 0;
Exit;
end;
{$ENDIF}
if IPAddr = u_long(INADDR_NONE) then begin
if StrComp(szData, '255.255.255.255') = 0 then begin
Result.s_addr := u_long(INADDR_BROADCAST);
Exit;
end;
raise ESocketException.Create('WSocketResolveHost: ''' + InAddr + ''' Invalid IP address.');
end;
Result.s_addr := IPAddr;
Exit;
end;
{ Address is a hostname }
Phe := WSocket_GetHostByName(szData);
if Phe = nil then
raise ESocketException.CreateFmt(
'WSocketResolveHost: Cannot convert host address ''%s''',
[InAddr]);
Result.s_addr := PInAddr(Phe^.h_addr_list^)^.s_addr;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Convert port name or number to number in host order (ftp -> 21) }
function WSocketResolvePort(Port : String; Proto : String) : Word;
var
szPort : array [0..31] of char;
szProto : array [0..31] of char;
Pse : Pservent;
begin
if (Length(Port) = 0) or (Length(Port) >= SizeOf(szPort)) then
raise ESocketException.Create('WSocketResolvePort: Invalid Port.');
if IsDigit(Port[1]) then
Result := atoi(Port)
else begin
StrPCopy(szPort, Trim(Port));
StrPCopy(szProto, Trim(Proto));
{ if not DllStarted then
LoadWinsock(WINSOCKET); 14/02/99 }
if szProto[0] = #0 then
Pse := WSocket_GetServByName(szPort, nil)
else
Pse := WSocket_GetServByName(szPort, szProto);
if Pse = nil then
raise ESocketException.CreateFmt(
'WSocketResolvePort: Cannot convert port ''%s''',
[Port]);
Result := WSocket_ntohs(Pse^.s_port);
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocketResolveProto(sProto : String) : integer;
var
szProto : array [0..31] of char;
Ppe : Pprotoent;
begin
if (Length(sProto) = 0) or (Length(sProto) >= SizeOf(szProto)) then
raise ESocketException.Create('WSocketResolveProto: Invalid Protocol.');
sProto := Trim(sProto);
if IsDigit(sProto[1]) then
Result := atoi(sProto)
else begin
StrPCopy(szProto, sProto);
{ if not DllStarted then
LoadWinsock(WINSOCKET); 14/02/99 }
ppe := WSocket_getprotobyname(szProto);
if Ppe = nil then
raise ESocketException.CreateFmt(
'WSocketResolveProto: Cannot convert protocol ''%s''',
[sProto]);
Result := ppe^.p_proto;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomWSocket.GetAddr : String;
begin
Result := FAddrStr;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomWSocket.GetSockName(var saddr : TSockAddrIn; var saddrlen : Integer) : integer;
begin
Result := WSocket_GetSockName(FHSocket, TSockAddr(saddr), saddrlen);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomWSocket.GetPeerAddr: string;
var
saddr : TSockAddrIn;
saddrlen : integer;
szAddr : PChar;
begin
Result := 'error';
if FState = wsConnected then begin
saddrlen := sizeof(saddr);
if WSocket_GetPeerName(FHSocket, TSockAddr(saddr), saddrlen) = 0 then begin
szAddr := WSocket_inet_ntoa(saddr.sin_addr);
Result := StrPas(szAddr);
end
else begin
SocketError('GetPeerName');
Exit;
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomWSocket.GetPeerPort: string;
var
saddr : TSockAddrIn;
saddrlen : integer;
begin
Result := 'error';
if FState = wsConnected then begin
saddrlen := sizeof(saddr);
if WinSock.GetPeerName(FHSocket, TSockAddr(saddr), saddrlen) = 0 then
Result := IntToStr(ntohs(saddr.sin_port))
else begin
SocketError('GetPeerPort');
Exit;
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomWSocket.GetPeerName(var Name : TSockAddrIn; NameLen : Integer) : integer;
begin
if FState = wsConnected then
Result := WSocket_GetPeerName(FHSocket, TSockAddr(Name), NameLen)
else
Result := SOCKET_ERROR;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.CancelDnsLookup;
begin
if FDnsLookupHandle = 0 then
Exit;
if WSocket_WSACancelAsyncRequest(FDnsLookupHandle) <> 0 then begin
FDnsLookupHandle := 0;
SocketError('WSACancelAsyncRequest');
Exit;
end;
FDnsLookupHandle := 0;
if not (csDestroying in ComponentState) then
TriggerDnsLookupDone(WSAEINTR);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.DnsLookup(HostName : String);
var
IPAddr : TInAddr;
begin
if HostName = '' then begin
RaiseException('DNS lookup: invalid host name.');
TriggerDnsLookupDone(WSAEINVAL);
Exit;
end;
{ Cancel any pending lookup }
if FDnsLookupHandle <> 0 then
WSocket_WSACancelAsyncRequest(FDnsLookupHandle);
FDnsResult := '';
FDnsResultList.Clear;
{$IFDEF VER80}
{ Delphi 1 do not automatically add a terminating nul char }
HostName := HostName + #0;
{$ENDIF}
IPAddr.S_addr := WSocket_inet_addr(@HostName[1]);
if IPAddr.S_addr <> u_long(INADDR_NONE) then begin
FDnsResult := StrPas(WSocket_inet_ntoa(IPAddr));
TriggerDnsLookupDone(0);
Exit;
end;
FDnsLookupHandle := WSocket_WSAAsyncGetHostByName(
FWindowHandle,
WM_ASYNCGETHOSTBYNAME,
@HostName[1],
@FDnsLookupBuffer,
SizeOf(FDnsLookupBuffer));
if FDnsLookupHandle = 0 then begin
RaiseExceptionFmt(
'%s: can''t start DNS lookup, error #%d',
[HostName, WSocket_WSAGetLastError]);
Exit;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.ReverseDnsLookup(HostAddr: String);
var
szAddr : array [0..256] of Char;
lAddr : u_long;
begin
if HostAddr = '' then begin
RaiseException('DNS lookup: invalid host name.');
TriggerDnsLookupDone(WSAEINVAL);
Exit;
end;
{ Cancel any pending lookup }
if FDnsLookupHandle <> 0 then
WSocket_WSACancelAsyncRequest(FDnsLookupHandle);
FDnsResult := '';
FDnsResultList.Clear;
StrPCopy(szAddr, HostAddr);
lAddr := WSocket_inet_addr(szAddr);
FDnsLookupHandle := WSocket_WSAAsyncGetHostByAddr(
FWindowHandle,
WM_ASYNCGETHOSTBYADDR,
PChar(@lAddr), 4, PF_INET,
@FDnsLookupBuffer,
SizeOf(FDnsLookupBuffer));
if FDnsLookupHandle = 0 then
RaiseExceptionFmt('%s: can''t start DNS lookup, error #%d',
[HostAddr, WSocket_WSAGetLastError]);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.BindSocket;
var
SockName : TSockAddr;
SockNamelen : Integer;
LocalSockName : TSockAddrIn;
begin
FillChar(LocalSockName, Sizeof(LocalSockName), 0);
SockNamelen := sizeof(LocalSockName);
LocalSockName.sin_family := AF_INET;
LocalSockName.sin_port := WSocket_htons(FLocalPortNum);
LocalSockName.sin_addr.s_addr := INADDR_ANY;
if WSocket_bind(HSocket, LocalSockName, SockNamelen) <> 0 then begin
RaiseExceptionFmt('winsock.bind failed, error #%d', [WSocket_WSAGetLastError]);
Exit;
end;
SockNamelen := sizeof(SockName);
if WSocket_getsockname(FHSocket, SockName, SockNamelen) <> 0 then begin
RaiseExceptionFmt('winsock.getsockname failed, error #%d',
[WSocket_WSAGetLastError]);
Exit;
end;
{ FLocalPort := ntohs(SockName.sin_port); }
FLocalPortNum := WSocket_ntohs(SockName.sin_port);
FLocalPortStr := IntToStr(FLocalPortNum);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.SetLingerOption;
var
iStatus : integer;
li : TLinger;
begin
if FLingerOnOff = wsLingerNoSet then
Exit; { Option set is disabled, ignore }
if FHSocket = INVALID_SOCKET then begin
RaiseException('Cannot set linger option at this time');
Exit;
end;
li.l_onoff := Ord(FLingerOnOff); { 0/1 = disable/enable linger }
li.l_linger := FLingerTimeout; { timeout in seconds }
iStatus := WSocket_setsockopt(FHSocket, SOL_SOCKET,
SO_LINGER, @li, SizeOf(li));
if iStatus <> 0 then begin
SocketError('setsockopt(SO_LINGER)');
Exit;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.Connect;
var
iStatus : integer;
optval : integer;
begin
if (FHSocket <> INVALID_SOCKET) and (FState <> wsClosed) then begin
RaiseException('Connect: Socket already in use');
Exit;
end;
if not FPortAssigned then begin
RaiseException('Connect: No Port Specified');
Exit;
end;
if not FAddrAssigned then begin
RaiseException('Connect: No IP Address Specified');
Exit;
end;
if not FProtoAssigned then begin
RaiseException('Connect: No Protocol Specified');
Exit;
end;
try
if not FProtoResolved then begin
{ The next line will trigger an exception in case of failure }
FProto := WSocketResolveProto(FProtoStr);
if FProto = IPPROTO_UDP then
FType := SOCK_DGRAM
else
FType := SOCK_STREAM;
FProtoResolved := TRUE;
end;
if not FPortResolved then begin
{ The next line will trigger an exception in case of failure }
FPortNum := WSocketResolvePort(FPortStr, GetProto);
sin.sin_port := WSocket_htons(FPortNum);
FPortResolved := TRUE;
end;
if not FLocalPortResolved then begin
{ The next line will trigger an exception in case of failure }
FLocalPortNum := WSocketResolvePort(FLocalPortStr, GetProto);
FLocalPortResolved := TRUE;
end;
if not FAddrResolved then begin
{ The next line will trigger an exception in case of failure }
sin.sin_addr.s_addr := WSocketResolveHost(FAddrStr).s_addr;
FAddrResolved := TRUE;
end;
except
on E:Exception do begin
RaiseException('connect: ' + E.Message);
Exit;
end;
end;
{ Remove any data from the internal output buffer }
{ (should already be empty !) }
DeleteBufferedData;
FHSocket := WSocket_socket(FAddrFormat, FType, FProto);
if FHSocket = INVALID_SOCKET then begin
SocketError('Connect (socket)');
Exit;
end;
ChangeState(wsOpened);
if FType = SOCK_DGRAM then begin
BindSocket;
if sin.sin_addr.S_addr = u_long(INADDR_BROADCAST) then begin
OptVal := 1;
iStatus := WSocket_setsockopt(FHSocket, SOL_SOCKET, SO_BROADCAST,
PChar(@OptVal), SizeOf(OptVal));
if iStatus <> 0 then begin
SocketError('setsockopt(SO_BROADCAST)');
Exit;
end;
end;
end
else begin
{ Socket type is SOCK_STREAM }
if FLocalPortNum <> 0 then
BindSocket;
SetLingerOption;
optval := -1;
iStatus := WSocket_setsockopt(FHSocket, SOL_SOCKET,
SO_KEEPALIVE, @optval, SizeOf(optval));
if iStatus <> 0 then begin
SocketError('setsockopt(SO_KEEPALIVE)');
Exit;
end;
optval := -1;
iStatus := WSocket_setsockopt(FHSocket, SOL_SOCKET,
SO_REUSEADDR, @optval, SizeOf(optval));
if iStatus <> 0 then begin
SocketError('setsockopt(SO_REUSEADDR)');
Exit;
end;
end;
iStatus := WSocket_WSAASyncSelect(FHSocket, Handle, WM_ASYNCSELECT,
FD_READ or FD_WRITE or FD_CLOSE or
FD_ACCEPT or FD_CONNECT);
if iStatus <> 0 then begin
SocketError('WSAAsyncSelect');
Exit;
end;
if FType = SOCK_DGRAM then begin
ChangeState(wsConnected);
TriggerSessionConnected(0);
end
else begin
iStatus := WSocket_connect(FHSocket, TSockAddr(sin), sizeof(sin));
if iStatus = 0 then
ChangeState(wsConnecting)
else begin
iStatus := WSocket_WSAGetLastError;
if iStatus = WSAEWOULDBLOCK then
ChangeState(wsConnecting)
else begin
FLastError := WSocket_WSAGetLastError;
SocketError('Connect');
Exit;
end;
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.Listen;
var
iStatus : integer;
begin
if not FPortAssigned then begin
WSocket_WSASetLastError(WSAEINVAL);
SocketError('listen: port not assigned');
Exit;
end;
if not FProtoAssigned then begin
WSocket_WSASetLastError(WSAEINVAL);
SocketError('listen: protocol not assigned');
Exit;
end;
if not FAddrAssigned then begin
WSocket_WSASetLastError(WSAEINVAL);
SocketError('listen: address not assigned');
Exit;
end;
try
if not FProtoResolved then begin
{ The next line will trigger an exception in case of failure }
FProto := WSocketResolveProto(FProtoStr);
if FProto = IPPROTO_UDP then
FType := SOCK_DGRAM
else
FType := SOCK_STREAM;
FProtoResolved := TRUE;
end;
if not FPortResolved then begin
{ The next line will trigger an exception in case of failure }
FPortNum := WSocketResolvePort(FPortStr, GetProto);
sin.sin_port := WSocket_htons(FPortNum);
FPortResolved := TRUE;
end;
if not FAddrResolved then begin
{ The next line will trigger an exception in case of failure }
sin.sin_addr.s_addr := WSocketResolveHost(FAddrStr).s_addr;
FAddrResolved := TRUE;
end;
except
on E:Exception do begin
RaiseException('listen: ' + E.Message);
Exit;
end;
end;
{ Remove any data from the internal output buffer }
{ (should already be empty !) }
DeleteBufferedData;
FHSocket := WSocket_socket(FAddrFormat, FType, FProto);
if FHSocket = INVALID_SOCKET then begin
SocketError('socket');
exit;
end;
iStatus := WSocket_bind(FHSocket, TSockAddr(sin), sizeof(sin));
if iStatus = 0 then
ChangeState(wsBound)
else begin
SocketError('Bind');
Close;
exit;
end;
if FType = SOCK_DGRAM then begin
ChangeState(wsListening);
ChangeState(wsConnected);
TriggerSessionConnected(0);
end
else if FType = SOCK_STREAM then begin
iStatus := WSocket_listen(FHSocket, 5);
if iStatus = 0 then
ChangeState(wsListening)
else begin
SocketError('Listen');
Exit;
end;
end;
iStatus := WSocket_WSAASyncSelect(FHSocket, Handle, WM_ASYNCSELECT,
FD_READ or FD_WRITE or
FD_ACCEPT or FD_CLOSE);
if iStatus <> 0 then begin
SocketError('WSAASyncSelect');
exit;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomWSocket.Accept: TSocket;
var
len : integer;
begin
if FState <> wsListening then begin
WSocket_WSASetLastError(WSAEINVAL);
SocketError('not a listening socket');
Result := INVALID_SOCKET;
Exit;
end;
len := sizeof(sin);
{$IFDEF VER100}
{ Delphi 3 has changed var parameters to pointers }
FASocket := WSocket_accept(FHSocket, @sin, @len);
{$ELSE}
{$IFDEF VER93}
{ C++Builder 1 has changed var parameters to pointers }
FASocket := WSocket_accept(FHSocket, @sin, @len);
{$ELSE}
{$IFDEF VER110}
{ C++Builder 3 has changed var parameters to pointers }
FASocket := WSocket_accept(FHSocket, @sin, @len);
{$ELSE}
{$IFDEF VER120}
{ Delphi 4 has changed var parameters to pointers }
FASocket := WSocket_accept(FHSocket, @sin, @len);
{$ELSE}
{$IFDEF VER125}
{ C++Builder 4 has changed var parameters to pointers }
FASocket := WSocket_accept(FHSocket, @sin, @len);
{$ELSE}
FASocket := WSocket_accept(FHSocket, TSockAddr(sin), len);
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
if FASocket = INVALID_SOCKET then begin
SocketError('Accept');
Result := INVALID_SOCKET;
Exit;
end
else
Result := FASocket;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.Pause;
begin
FPaused := TRUE;
WSocket_WSAASyncSelect(FHSocket, Handle, 0, 0);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.Resume;
begin
FPaused := FALSE;
WSocket_WSAASyncSelect(FHSocket, Handle, WM_ASYNCSELECT,
FD_READ or FD_WRITE or FD_CLOSE or FD_CONNECT);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.Shutdown(How : Integer);
begin
if FHSocket <> INVALID_SOCKET then
WSocket_shutdown(FHSocket, How);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.DeleteBufferedData;
var
nItem : Integer;
begin
{ Delete all data buffer }
for nItem := 0 to FBufList.Count - 1 do
TBuffer(FBufList.Items[nItem]).Free;
FBufList.Clear;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.Abort;
begin
CancelDnsLookup;
DeleteBufferedData;
{ Be sure to close as fast as possible (abortive close) }
if (State = wsConnected) and (FProto = IPPROTO_TCP) then begin
LingerOnOff := wsLingerOff;
SetLingerOption;
end;
InternalClose(FALSE, 0);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.Close;
begin
InternalClose(TRUE, 0);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.Flush;
begin
while (FHSocket <> INVALID_SOCKET) and { No more socket }
(not bAllSent) do begin { Nothing to send }
{ Break; }
TryToSend;
MessagePump;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.InternalClose(bShut : Boolean; Error : Word);
var
iStatus : integer;
{ Buffer : array [0..127] of Char; }
begin
if FHSocket = INVALID_SOCKET then begin
if FState <> wsClosed then begin
ChangeState(wsClosed);
AssignDefaultValue;
end;
exit;
end;
if FState = wsClosed then
Exit;
{ 11/10/98 called shutdown(1) instead of shutdonw(2). This disable only }
{ reception. Disabling data send produced data lost is some cases. For }
{ example when a client open the connection, send some data fast then close }
{ the connection immediately, even using the linger option. }
if bShut then
ShutDown(1);
if FHSocket <> INVALID_SOCKET then begin
repeat
{ Close the socket }
iStatus := WSocket_closesocket(FHSocket);
FHSocket := INVALID_SOCKET;
if iStatus <> 0 then begin
FLastError := WSocket_WSAGetLastError;
if FLastError <> WSAEWOULDBLOCK then begin
{ Ignore the error occuring when winsock DLL not }
{ initialized (occurs when using TWSocket from a DLL) }
if FLastError = WSANOTINITIALISED then
break;
SocketError('Disconnect (closesocket)');
Exit;
end;
MessagePump;
end;
until iStatus = 0;
end;
ChangeState(wsClosed);
if (not (csDestroying in ComponentState)) and
(not FCloseInvoked) and Assigned(FOnSessionClosed) then begin
FCloseInvoked := TRUE;
TriggerSessionClosed(Error);
end;
{ 29/09/98 Protect AssignDefaultValue because SessionClosed event handler }
{ may have destroyed the component. }
try
AssignDefaultValue;
except
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.WaitForClose;
var
lCount : LongInt;
Status : Integer;
Ch : Char;
begin
while (FHSocket <> INVALID_SOCKET) and (FState <> wsClosed) do begin
MessagePump;
if WSocket_ioctlsocket(FHSocket, FIONREAD, lCount) = SOCKET_ERROR then
break;
if lCount > 0 then
TriggerDataAvailable(0);
Status := DoRecv(Ch, 0, 0);
if Status <= 0 then begin
FLastError := WSocket_WSAGetLastError;
if FLastError <> WSAEWOULDBLOCK then
break;
end;
MessagePump;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocketGetHostByAddr(Addr : String) : PHostEnt;
var
szAddr : array[0..256] of char;
lAddr : u_long;
begin
{ if not DllStarted then
LoadWinsock(WINSOCKET); 14/02/99 }
StrPCopy(szAddr, Addr);
lAddr := WSocket_inet_addr(szAddr);
Result := winsock.gethostbyaddr(PChar(@lAddr), 4, PF_INET);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocketResolveIp(IpAddr : String) : String;
var
Phe : PHostEnt;
begin
phe := WSocketGetHostByAddr(IpAddr);
if Phe = nil then
Result := ''
else begin
SetLength(Result, StrLen(Phe^.h_name));
StrCopy(@Result[1], Phe^.h_name);
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocketGetHostByName(Name : String) : PHostEnt;
var
szName : array[0..256] of char;
begin
{ if not DllStarted then
LoadWinsock(WINSOCKET); 14/02/99 }
StrPCopy(szName, Name);
Result := WSocket_gethostbyname(szName);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function LocalIPList : TStrings;
var
phe : PHostEnt;
begin
IPList.Clear;
Result := IPList;
phe := WSocketGetHostByName(LocalHostName);
if phe <> nil then
GetIpList(Phe, IPList);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function LocalHostName : String;
var
Buffer : array [0..63] of char;
begin
{ if not DllStarted then
LoadWinsock(WINSOCKET); 14/02/99 }
if WSocket_gethostname(Buffer, SizeOf(Buffer)) <> 0 then
raise ESocketException.Create('Winsock.GetHostName failed');
Result := StrPas(Buffer);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomWSocket.TimerIsSet(var tvp : TTimeVal) : Boolean;
begin
Result := (tvp.tv_sec <> 0) or (tvp.tv_usec <> 0);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomWSocket.TimerCmp(var tvp : TTimeVal; var uvp : TTimeVal; IsEqual : Boolean) : Boolean;
begin
Result := (tvp.tv_sec = uvp.tv_sec) and (tvp.tv_usec = uvp.tv_usec);
if not IsEqual then
Result := not Result;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.TimerClear(var tvp : TTimeVal);
begin
tvp.tv_sec := 0;
tvp.tv_usec := 0;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.SetSendFlags(newValue : TSocketSendFlags);
begin
case newValue of
wsSendNormal: FSendFlags := 0;
wsSendUrgent: FSendFlags := MSG_OOB;
else
RaiseException('Invalid SendFlags');
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomWSocket.GetSendFlags : TSocketSendFlags;
begin
case FSendFlags of
0 : Result := wsSendNormal;
MSG_OOB : Result := wsSendUrgent;
else
RaiseException('Invalid internal SendFlags');
Result := wsSendNormal;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.TriggerDisplay(Msg : String);
begin
if Assigned(FOnDisplay) then
FOnDisplay(Self, Msg);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.TriggerSessionAvailable(Error : Word);
begin
if Assigned(FOnSessionAvailable) then
FOnSessionAvailable(Self, Error);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.TriggerSessionConnected(Error : Word);
begin
if Assigned(FOnSessionConnected) then
FOnSessionConnected(Self, Error);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.TriggerSessionClosed(Error : Word);
begin
if Assigned(FOnSessionClosed) then
FOnSessionClosed(Self, Error);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomWSocket.TriggerDataAvailable(Error : Word) : Boolean;
begin
Result := Assigned(FOnDataAvailable);
if not Result then
Exit;
{$IFDEF TOMASEK} { 23/01/99 }
{ Do not allow FD_READ messages, this will prevent reentering the }
{ OnDataAvailable event handler. }
WSocket_WSAASyncSelect(FHSocket, Handle, WM_ASYNCSELECT,
FD_WRITE or FD_CLOSE or FD_CONNECT);
try
FRcvdFlag := TRUE;
while Result and FRcvdFlag do begin
{ Trigger user code. This will normally call DoRecv which will }
{ update FRcvdFlag. }
{ If user code is wrong, we'll loop forever ! }
FOnDataAvailable(Self, Error);
Result := Assigned(FOnDataAvailable);
end;
finally
{ Allow all events now }
WSocket_WSAASyncSelect(FHSocket, Handle, WM_ASYNCSELECT,
FD_READ or FD_WRITE or FD_CLOSE or FD_CONNECT);
end;
{$ELSE} { 23/01/99 }
FOnDataAvailable(Self, Error); { 23/01/99 }
{$ENDIF} { 23/01/99 }
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.TriggerDataSent(Error : Word);
begin
if Assigned(FOnDataSent) then
FOnDataSent(Self, Error);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.TriggerError;
begin
if Assigned(FOnError) then
FOnError(Self);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.TriggerDNSLookupDone(Error : Word);
begin
if Assigned(FOnDNSLookupDone) then
FOnDNSLookupDone(Self, Error);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.TriggerChangeState(OldState, NewState : TSocketState);
begin
if Assigned(FOnChangeState) then
FOnChangeState(Self, OldState, NewState);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.SocketError(sockfunc: string);
var
Error : integer;
Line : string;
begin
Error := WSocket_WSAGetLastError;
Line := 'Error '+ IntToStr(Error) + ' in function ' + sockfunc +
#13#10 + WSocketErrorDesc(Error);
if (Error = WSAECONNRESET) or
(Error = WSAENOTCONN) then begin
WSocket_closesocket(FHSocket);
FHSocket := INVALID_SOCKET;
ChangeState(wsClosed);
end;
FLastError := Error;
RaiseException(Line);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocketErrorDesc(error: integer) : string;
begin
case error of
0:
WSocketErrorDesc := 'No Error';
WSAEINTR:
WSocketErrorDesc := 'Interrupted system call';
WSAEBADF:
WSocketErrorDesc := 'Bad file number';
WSAEACCES:
WSocketErrorDesc := 'Permission denied';
WSAEFAULT:
WSocketErrorDesc := 'Bad address';
WSAEINVAL:
WSocketErrorDesc := 'Invalid argument';
WSAEMFILE:
WSocketErrorDesc := 'Too many open files';
WSAEWOULDBLOCK:
WSocketErrorDesc := 'Operation would block';
WSAEINPROGRESS:
WSocketErrorDesc := 'Operation now in progress';
WSAEALREADY:
WSocketErrorDesc := 'Operation already in progress';
WSAENOTSOCK:
WSocketErrorDesc := 'Socket operation on non-socket';
WSAEDESTADDRREQ:
WSocketErrorDesc := 'Destination address required';
WSAEMSGSIZE:
WSocketErrorDesc := 'Message too long';
WSAEPROTOTYPE:
WSocketErrorDesc := 'Protocol wrong type for socket';
WSAENOPROTOOPT:
WSocketErrorDesc := 'Protocol not available';
WSAEPROTONOSUPPORT:
WSocketErrorDesc := 'Protocol not supported';
WSAESOCKTNOSUPPORT:
WSocketErrorDesc := 'Socket type not supported';
WSAEOPNOTSUPP:
WSocketErrorDesc := 'Operation not supported on socket';
WSAEPFNOSUPPORT:
WSocketErrorDesc := 'Protocol family not supported';
WSAEAFNOSUPPORT:
WSocketErrorDesc := 'Address family not supported by protocol family';
WSAEADDRINUSE:
WSocketErrorDesc := 'Address already in use';
WSAEADDRNOTAVAIL:
WSocketErrorDesc := 'Address not available';
WSAENETDOWN:
WSocketErrorDesc := 'Network is down';
WSAENETUNREACH:
WSocketErrorDesc := 'Network is unreachable';
WSAENETRESET:
WSocketErrorDesc := 'Network dropped connection on reset';
WSAECONNABORTED:
WSocketErrorDesc := 'Connection aborted';
WSAECONNRESET:
WSocketErrorDesc := 'Connection reset by peer';
WSAENOBUFS:
WSocketErrorDesc := 'No buffer space available';
WSAEISCONN:
WSocketErrorDesc := 'Socket is already connected';
WSAENOTCONN:
WSocketErrorDesc := 'Socket is not connected';
WSAESHUTDOWN:
WSocketErrorDesc := 'Can''t send after socket shutdown';
WSAETOOMANYREFS:
WSocketErrorDesc := 'Too many references: can''t splice';
WSAETIMEDOUT:
WSocketErrorDesc := 'Connection timed out';
WSAECONNREFUSED:
WSocketErrorDesc := 'Connection refused';
WSAELOOP:
WSocketErrorDesc := 'Too many levels of symbolic links';
WSAENAMETOOLONG:
WSocketErrorDesc := 'File name too long';
WSAEHOSTDOWN:
WSocketErrorDesc := 'Host is down';
WSAEHOSTUNREACH:
WSocketErrorDesc := 'No route to host';
WSAENOTEMPTY:
WSocketErrorDesc := 'Directory not empty';
WSAEPROCLIM:
WSocketErrorDesc := 'Too many processes';
WSAEUSERS:
WSocketErrorDesc := 'Too many users';
WSAEDQUOT:
WSocketErrorDesc := 'Disc quota exceeded';
WSAESTALE:
WSocketErrorDesc := 'Stale NFS file handle';
WSAEREMOTE:
WSocketErrorDesc := 'Too many levels of remote in path';
WSASYSNOTREADY:
WSocketErrorDesc := 'Network sub-system is unusable';
WSAVERNOTSUPPORTED:
WSocketErrorDesc := 'WinSock DLL cannot support this application';
WSANOTINITIALISED:
WSocketErrorDesc := 'WinSock not initialized';
WSAHOST_NOT_FOUND:
WSocketErrorDesc := 'Host not found';
WSATRY_AGAIN:
WSocketErrorDesc := 'Non-authoritative host not found';
WSANO_RECOVERY:
WSocketErrorDesc := 'Non-recoverable error';
WSANO_DATA:
WSocketErrorDesc := 'No Data';
else
WSocketErrorDesc := 'Not a WinSock error';
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
X X X X X X X X X X X X X X
X X X X X X X X X X X
X X X X X X X X
X X X X X X X X X X X
X X X X X X X X
X X X X X X X X X X X X
X X X X X X X X X X X X
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSocksWSocket.AssignDefaultValue;
begin
inherited AssignDefaultValue;
FSocksState := socksData;
FSocksServer := '';
FSocksPort := '';
FSocksLevel := '5';
FRcvdCnt := 0;
FSocksPortAssigned := FALSE;
FSocksServerAssigned := FALSE;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSocksWSocket.SetSocksLevel(newValue : String);
begin
if State <> wsClosed then begin
RaiseException('Can''t change socks level if not closed');
Exit;
end;
if (newValue <> '4') and (newValue <> '5') and
(newValue <> '4A') and (newValue <> '4a') then begin
RaiseException('Invalid socks level. Must be 4, 4A or 5.');
Exit;
end;
FSocksLevel := UpperCase(newValue);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSocksWSocket.SetSocksPort(sPort : String);
begin
if State <> wsClosed then begin
RaiseException('Can''t change socks port if not closed');
Exit;
end;
FSocksPort := Trim(sPort);
if Length(FSocksPort) = 0 then begin
FSocksPortAssigned := FALSE;
Exit;
end;
FSocksPortAssigned := TRUE;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSocksWSocket.SetSocksServer(sServer : String);
begin
if State <> wsClosed then begin
RaiseException('Can''t change socks server if not closed');
Exit;
end;
FSocksServer := Trim(sServer);
if Length(FSocksServer) = 0 then begin
FSocksServerAssigned := FALSE;
Exit;
end;
FSocksServerAssigned := TRUE;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSocksWSocket.Listen;
begin
{ Check if we really wants to use socks server }
if not FSocksServerAssigned then begin
{ No socks server assigned, Listen as usual }
inherited Listen;
Exit;
end;
RaiseException('listening is not supported thru socks server');
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSocksWSocket.Connect;
begin
{ Check if we really wants to use socks server }
if not FSocksServerAssigned then begin
{ No socks server assigned, connect as usual }
inherited Connect;
Exit;
end;
if LowerCase(FProtoStr) <> 'tcp' then begin
RaiseException('tcp is the only protocol supported thru socks server');
Exit;
end;
try
if not FPortResolved then begin
{ The next line will trigger an exception in case of failure }
sin.sin_port := WSocket_htons(WSocketResolvePort(FSocksPort, FProtoStr));
FPortResolved := TRUE;
end;
if not FAddrResolved then begin
{ The next line will trigger an exception in case of failure }
sin.sin_addr.s_addr := WSocketResolveHost(FSocksServer).s_addr;
FAddrResolved := TRUE;
end;
{ The next line will trigger an exception in case of failure }
FPortNum := WSocketResolvePort(FPortStr, FProtoStr);
except
on E:Exception do begin
RaiseException('connect: ' + E.Message);
Exit;
end;
end;
FSocksState := socksNegociateMethods;
FRcvCnt := 0;
inherited Connect;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{function BufToStr(Buf : PChar; Cnt : Integer) : String;
begin
Result := '';
while Cnt > 0 do begin
if Buf^ in [#32..#126] then
Result := Result + Buf^
else
Result := Result + '#' + Format('%2.2d', [ord(Buf^)]);
Inc(Buf);
Dec(Cnt);
end;
end;}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSocksWSocket.TriggerSessionConnected(Error : Word);
var
Buf : array [0..2] of char;
begin
if FSocksState = socksNegociateMethods then begin
TriggerSocksConnected(Error);
if Error <> 0 then begin
inherited TriggerSessionConnected(Error);
Exit;
end;
if FSocksLevel[1] = '4' then
SocksDoConnect
else begin
if FSocksAuthentication = socksNoAuthentication then
FSocksAuthNumber := #$00 { No authentification }
else
FSocksAuthNumber := #$02; { Usercode/Password }
Buf[0] := #$05; { Version number }
Buf[1] := #$01; { Number of methods }
Buf[2] := FSocksAuthNumber; { Method identifier }
{TriggerDisplay('Send = ''' + BufToStr(Buf, 3) + '''');}
Send(@Buf, 3);
end;
end
else
inherited TriggerSessionConnected(Error);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSocksWSocket.TriggerSessionClosed(Error : Word);
begin
if FSocksState = socksAuthenticate then
TriggerSocksAuthState(socksAuthFailure);
inherited TriggerSessionClosed(Error);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSocksWSocket.TriggerSocksConnected(Error : Word);
begin
if Assigned(FOnSocksConnected) then
FOnSocksConnected(Self, Error);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSocksWSocket.TriggerSocksError(Error : Integer; Msg : String);
begin
if Assigned(FOnSocksError) then
FOnSocksError(Self, Error, Msg);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSocksWSocket.TriggerSocksAuthState(AuthState : TSocksAuthState);
begin
if Assigned(FOnSocksAuthState) then
FOnSocksAuthState(Self, AuthState);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSocksWSocket.SocksDoAuthenticate;
var
Buf : array [0..127] of char;
I : Integer;
begin
FSocksState := socksAuthenticate;
TriggerSocksAuthState(socksAuthStart);
Buf[0] := #$01; {06/03/99} { Socks version }
I := 1;
Buf[I] := chr(Length(FSocksUsercode));
Move(FSocksUsercode[1], Buf[I + 1], Length(FSocksUsercode));
I := I + 1 + Length(FSocksUsercode);
Buf[I] := chr(Length(FSocksPassword));
Move(FSocksPassword[1], Buf[I + 1], Length(FSocksPassword));
I := I + 1 + Length(FSocksPassword);
try
{TriggerDisplay('Send = ''' + BufToStr(Buf, I) + '''');}
Send(@Buf, I);
except
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSocksWSocket.SocksDoConnect;
type
pu_long = ^u_long;
var
Buf : array [0..127] of char;
I : Integer;
ErrCode : Integer;
begin
FSocksState := socksConnect;
if FSocksLevel[1] = '4' then begin
Buf[0] := #4;
Buf[1] := #1;
PWORD(@Buf[2])^ := WSocket_ntohs(FPortNum);
if FSocksLevel = '4A' then
pu_long(@Buf[4])^ := WSocket_inet_addr('0.0.0.1')
else begin
try
pu_long(@Buf[4])^ := WSocketResolveHost(FAddrStr).s_addr;
except
on E:Exception do begin
ErrCode := socksHostResolutionFailed;
TriggerSocksError(ErrCode, E.ClassName + ' ' + E.Message);
InternalClose(TRUE, ErrCode);
Exit;
end;
end;
end;
I := 8;
if Length(FSocksUsercode) > 0 then begin
{ I'm not sure it has to be like that ! Should I also use the }
{ password or not ? }
Move(FSocksUsercode[1], Buf[I], Length(FSocksUsercode));
I := I + Length(FSocksUsercode);
end;
Buf[I] := #0;
Inc(I);
if FSocksLevel = '4A' then begin
Move(FAddrStr[1], Buf[I], Length(FAddrStr));
I := I + Length(FAddrStr);
end;
Buf[I] := #0;
Inc(I);
end
else begin
Buf[0] := #$05; { Socks version }
Buf[1] := #$01; { Connect command }
Buf[2] := #$00; { Reserved, must be $00 }
Buf[3] := #$03; { Address type is domain name }
Buf[4] := chr(Length(FAddrStr));
{ Should check buffer overflow }
Move(FAddrStr[1], Buf[5], Length(FAddrStr));
I := 5 + Length(FAddrStr);
PWord(@Buf[I])^ := WSocket_htons(FPortNum);
I := I + 2;
end;
try
{TriggerDisplay('Send = ''' + BufToStr(Buf, I + 2) + '''');}
Send(@Buf, I);
except
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSocksWSocket.DataAvailableError(
ErrCode : Integer;
Msg : String);
begin
TriggerSocksError(ErrCode, Msg);
inherited TriggerSessionConnected(ErrCode);
InternalClose(TRUE, ErrCode);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomSocksWSocket.TriggerDataAvailable(Error : Word) : Boolean;
var
Len : Integer;
I : Integer;
ErrCode : Word;
ErrMsg : String;
InAddr : TInAddr;
AnsLen : Integer;
begin
if FSocksState = socksData then begin
Result := inherited TriggerDataAvailable(Error);
Exit;
end;
if Error <> 0 then begin
DataAvailableError(Error, 'data receive error');
Result := FALSE;
Exit;
end;
if FSocksState = socksNegociateMethods then begin
Result := TRUE;
Len := Receive(@FRcvBuf[FRcvCnt], Sizeof(FRcvBuf) - FRcvCnt - 1);
if Len < 0 then
Exit;
FRcvCnt := FRcvCnt + Len;
{TriggerDisplay('socksNegociateMethods FrcvBuf = ''' + BufToStr(FRcvBuf, FRcvCnt) + '''');}
if FSocksLevel[1] = '4' then begin
{ We should never comes here }
DataAvailableError(socksProtocolError, 'TWSocket logic error');
Exit;
end
else begin { SOCKS5 }
{ We are waiting only two bytes }
if FRcvCnt < 2 then
Exit;
{ if FRcvCnt <> 2 then begin 06/03/99}
{ DataAvailableError(socksProtocolError, 'too much data availaible');}
{ Exit; }
{ end; }
FRcvCnt := 0; { Clear receive counter }
if FRcvBuf[0] <> #$05 then begin
DataAvailableError(socksVersionError, 'socks version error');
Exit;
end;
if FRcvBuf[1] = #$00 then begin
{ No authentication required }
if FSocksAuthNumber <> #$00 then
{ We asked for authentification, so complains... }
TriggerSocksAuthState(socksAuthNotRequired);
end
else if FRcvBuf[1] = #$02 then begin
{ Usercode/Password authentication required }
SocksDoAuthenticate;
Exit;
end
else begin
DataAvailableError(socksAuthMethodError, 'authentification method not acceptable');
Exit;
end;
SocksDoConnect;
end;
end
else if FSocksState = socksConnect then begin
Result := TRUE;
{TriggerDisplay('socksConnect FrcvBuf = ''' + BufToStr(FRcvBuf, FRcvCnt) + '''');}
if FSocksLevel[1] = '4' then begin
{ We wants at most 8 characters }
Len := Receive(@FRcvBuf[FRcvCnt], 8 - FRcvCnt);
if Len < 0 then
Exit;
FRcvCnt := FRcvCnt + Len;
{ We are waiting for 8 bytes }
if FRcvCnt < 8 then
Exit;
FRcvCnt := 0; { Clear receive counter }
if FRcvBuf[0] <> #0 then begin
DataAvailableError(socksVersionError, 'socks version error');
Exit;
end;
if FRcvBuf[1] = #$90 then begin
case FRcvBuf[1] of
#$91: ErrCode := socksRejectedOrFailed;
#$92: ErrCode := socksConnectionRefused;
#$93: ErrCode := socksAuthenticationFailed;
else
ErrCode := socksUnassignedError;
end;
case ErrCode of
socksRejectedOrFailed :
ErrMsg := 'request rejected or failed';
socksConnectionRefused :
ErrMsg := 'connection refused';
socksAuthenticationFailed :
ErrMsg := 'authentification failed';
else
ErrMsg := 'unassigned error #' + IntToStr(Ord(FRcvBuf[1]));
end;
DataAvailableError(ErrCode, ErrMsg);
Exit;
end;
FSocksState := socksData;
inherited TriggerSessionConnected(0);
Result := inherited TriggerDataAvailable(0);
end
else begin { SOCKS5 }
Len := Receive(@FRcvBuf[FRcvCnt], Sizeof(FRcvBuf) - FRcvCnt - 1);
if Len < 0 then
Exit;
FRcvCnt := FRcvCnt + Len;
if FRcvCnt >= 1 then begin
{ First byte is version, we expect version 5 }
if FRcvBuf[0] <> #$05 then begin
DataAvailableError(socksVersionError, 'socks version error');
Exit;
end;
end;
if FRcvCnt >= 2 then begin
if FRcvBuf[1] <> #$00 then begin
case FRcvBuf[1] of
#1: ErrCode := socksGeneralFailure;
#2: ErrCode := socksConnectionNotAllowed;
#3: ErrCode := socksNetworkUnreachable;
#4: ErrCode := socksHostUnreachable;
#5: ErrCode := socksConnectionRefused;
#6: ErrCode := socksTtlExpired;
#7: ErrCode := socksUnknownCommand;
#8: ErrCode := socksUnknownAddressType;
else
ErrCode := socksUnassignedError;
end;
case ErrCode of
socksGeneralFailure :
ErrMsg := 'general SOCKS server failure';
socksConnectionNotAllowed :
ErrMsg := 'connection not allowed by ruleset';
socksNetworkUnreachable :
ErrMsg := 'network unreachable';
socksHostUnreachable :
ErrMsg := 'host unreachable';
socksConnectionRefused :
ErrMsg := 'connection refused';
socksTtlExpired :
ErrMsg := 'time to live expired';
socksUnknownCommand :
ErrMsg := 'command not supported';
socksUnknownAddressType :
ErrMsg := 'address type not supported';
else
ErrMsg := 'unassigned error #' + IntToStr(Ord(FRcvBuf[1]));
end;
DataAvailableError(ErrCode, ErrMsg);
Exit;
end;
end;
if FRcvCnt < 5 then
Exit;
{ We have enough data to learn the answer length }
if FRcvBuf[3] = #$01 then
AnsLen := 10 { IP V4 address }
else if FRcvBuf[3] = #$03 then
AnsLen := 7 + Ord(FRcvBuf[4]) { Domain name }
else
AnsLen := 5; { Other unsupported }
if FRcvCnt < AnsLen then
Exit;
if FRcvBuf[3] = #$01 then begin
{ IP V4 address }
Move(FRcvBuf[4], InAddr, 4);
FBoundAddr := StrPas(WSocket_inet_ntoa(InAddr));
I := 4 + 4;
end
else if FRcvBuf[3] = #$03 then begin
{ Domain name }
SetLength(FBoundAddr, Ord(FRcvBuf[4]));
Move(FRcvBuf[4], FBoundAddr[1], Length(FBoundAddr));
I := 4 + Ord(FRcvBuf[4]) + 1;
end
else begin
{ Unsupported address type }
DataAvailableError(socksUnknownAddressType, 'address type not supported');
Exit;
end;
FBoundPort := format('%d', [WSocket_ntohs(PWord(@FRcvBuf[I])^)]);
I := I + 2;
FSocksState := socksData;
inherited TriggerSessionConnected(0);
FRcvdCnt := FRcvCnt - I;
if FRcvdCnt < 0 then
FRcvdCnt := 0
else
FRcvdPtr := @FRcvBuf[I];
Result := inherited TriggerDataAvailable(0);
end;
end
else if FSocksState = socksAuthenticate then begin
Result := TRUE;
Len := Receive(@FRcvBuf[FRcvCnt], Sizeof(FRcvBuf) - FRcvCnt - 1);
if Len < 0 then
Exit;
FRcvCnt := FRcvCnt + Len;
{TriggerDisplay('socksAuthenticate FrcvBuf = ''' + BufToStr(FRcvBuf, FRcvCnt) + '''');}
if FRcvCnt >= 1 then begin
{ First byte is version, we expect version 5 }
if FRcvBuf[0] <> #$01 then begin { 06/03/99 }
TriggerSocksAuthState(socksAuthFailure);
DataAvailableError(socksVersionError, 'socks version error');
Exit;
end;
end;
if FRcvCnt = 2 then begin
{ Second byte is status }
if FRcvBuf[1] <> #$00 then begin
TriggerSocksAuthState(socksAuthFailure);
DataAvailableError(socksAuthenticationFailed, 'socks authentication failed');
Exit;
end;
end
else if FRcvCnt > 2 then begin
TriggerSocksAuthState(socksAuthFailure);
DataAvailableError(socksProtocolError, 'too much data availaible');
Exit;
end;
FRcvCnt := 0; { 06/03/99 }
TriggerSocksAuthState(socksAuthSuccess);
SocksDoConnect;
end
else begin
{ We should never comes here ! }
DataAvailableError(socksInternalError, 'internal error');
Result := FALSE;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomSocksWSocket.GetRcvdCount : LongInt;
begin
if FRcvdCnt <= 0 then
Result := inherited GetRcvdCount
else
Result := FRcvdCnt;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomSocksWSocket.DoRecv(
var Buffer;
BufferSize : Integer;
Flags : Integer) : Integer;
begin
if FRcvdCnt <= 0 then begin
Result := inherited DoRecv(Buffer, BufferSize, Flags);
Exit;
end;
{ We already have received data into our internal buffer }
if FRcvdCnt <= BufferSize then begin
{ User buffer is greater than received data, copy all and clear }
Move(FRcvdPtr^, Buffer, FRcvdCnt);
Result := FRcvdCnt;
FRcvdCnt := 0;
Exit;
end;
{ User buffer is smaller, copy as much as possible }
Move(FRcvdPtr^, Buffer, BufferSize);
Result := BufferSize;
FRcvdPtr := FRcvdPtr + BufferSize;
FRcvdCnt := FRcvdCnt - BufferSize;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
X X X X X X X X
X X X X X X
X X X X X X
X X X X X X X X
X X X X X
X X X X X
X X X X X X X X X X X
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TCustomLineWSocket.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FLineEnd := #13#10;
FLineMode := FALSE;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TCustomLineWSocket.Destroy;
begin
if FRcvdPtr <> nil then begin
FreeMem(FRcvdPtr, FRcvBufSize);
FRcvdPtr := nil;
FRcvBufSize := 0;
end;
inherited Destroy;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomLineWSocket.WndProc(var MsgRec: TMessage);
begin
with MsgRec do begin
if Msg = WM_TRIGGER_DATA_AVAILABLE then begin
{ We *MUST* handle all exception to avoid application shutdown }
try
WMTriggerDataAvailable(MsgRec)
except
on E:Exception do
HandleBackGroundException(E);
end;
end
else
inherited WndProc(MsgRec);
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomLineWSocket.WMTriggerDataAvailable(var msg: TMessage);
begin
while FRcvdCnt > 0 do
TriggerDataAvailable(0);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomLineWSocket.SetLineMode(newValue : Boolean);
begin
if FLineMode = newValue then
Exit;
FLineMode := newValue;
if (FRcvdCnt > 0) or (FLineLength > 0) then
PostMessage(Handle, WM_TRIGGER_DATA_AVAILABLE, 0, 0);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomLineWSocket.GetRcvdCount : LongInt;
begin
if not FLineMode then
Result := inherited GetRcvdCount
else
Result := FLineLength;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomLineWSocket.DoRecv(
var Buffer;
BufferSize : Integer;
Flags : Integer) : Integer;
begin
if FLineMode and (FLineLength > 0) then begin
{ We are in line mode an a line is received }
if FLineLength <= BufferSize then begin
{ User buffer is greater than received data, copy all and clear }
Move(FRcvdPtr^, Buffer, FLineLength);
Result := FLineLength;
FLineLength := 0;
Exit;
end;
{ User buffer is smaller, copy as much as possible }
Move(FRcvdPtr^, Buffer, BufferSize);
Result := BufferSize;
{ Move the end of line to beginning of buffer to be read the next time }
Move(FRcvdPtr[BufferSize], FRcvdPtr^, FLineLength - BufferSize);
FLineLength := FLineLength - BufferSize;
Exit;
end;
if FLineMode or (FRcvdCnt <= 0) then begin
{ There is nothing in our internal buffer }
Result := inherited DoRecv(Buffer, BufferSize, Flags);
Exit;
end;
{ We already have received data into our internal buffer }
if FRcvdCnt <= BufferSize then begin
{ User buffer is greater than received data, copy all and clear }
Move(FRcvdPtr^, Buffer, FRcvdCnt);
Result := FRcvdCnt;
FRcvdCnt := 0;
Exit;
end;
{ User buffer is smaller, copy as much as possible }
Move(FRcvdPtr^, Buffer, BufferSize);
Result := BufferSize;
FRcvdPtr := FRcvdPtr + BufferSize;
FRcvdCnt := FRcvdCnt - BufferSize;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Edit received data. Handle TAB and BACKSPACE characters. }
{ A data packet has been received into FRcvPtr buffer, starting from }
{ FRcvdCnt offset. Packet size if passed as the Len argument. }
procedure TCustomLineWSocket.EditLine(var Len : Integer);
var
Buf : PChar;
BufSize : Integer;
I : Integer;
J : Integer;
Edited : Boolean;
NewCnt : Integer;
NewSize : Integer;
const
BackString : String = #8 + ' ' + #8;
begin
BufSize := 0;
try
Edited := FALSE;
I := FRcvdCnt;
J := FRcvdCnt;
NewCnt := FRcvdCnt;
{ Loop to process all received char }
while I < (FRcvdCnt + Len) do begin
if FRcvdPtr[I] = #8 then begin { BACKSPACE character }
if FLineEcho and (J > 0) then
SendStr(BackString);
if not Edited then begin
{ Not edited yet, so we allocate a buffer to store }
{ edited data and we remember we edited data. }
Edited := TRUE;
{ Computer buffer size as a multiple of 256 bytes }
BufSize := ((FRcvdCnt + Len + 256) shr 8) shl 8;
GetMem(Buf, BufSize);
{ Copy data already processed }
Move(FRcvdPtr^, Buf^, I);
end;
if J > 0 then begin
Dec(J);
if J < NewCnt then
NewCnt := J;
end;
Inc(I);
end
else if FRcvdPtr[I] = #9 then begin { TAB character }
if not Edited then begin
{ Not edited yet, so we allocate a buffer to store }
{ edited data and we remember we edited data. }
Edited := TRUE;
{ Computer buffer size as a multiple of 256 bytes }
BufSize := ((FRcvdCnt + Len + 256) shr 8) shl 8;
GetMem(Buf, BufSize);
{ Copy data already processed }
Move(FRcvdPtr^, Buf^, I);
end;
repeat
if FLineEcho then
SendStr(' ');
Buf[J] := ' ';
Inc(J);
until (J and 7) = 0;
Inc(I);
end
else begin
if FLineEcho then
Send(@FRcvdPtr[I], 1);
if Edited then begin
if J >= BufSize then begin
{ Need to allocate more buffer space }
NewSize := BufSize + 256;
{$IFDEF VER80}
ReallocMem(Buf, BufSize, NewSize);
{$ELSE}
ReallocMem(Buf, NewSize);
{$ENDIF}
BufSize := NewSize;
end;
Buf[J] := FRcvdPtr[I];
end;
Inc(I);
Inc(J);
end;
end;
if Edited then begin
if J >= FRcvBufSize then begin
{ Current buffer is too small, allocate larger }
NewSize := J + 1;
{$IFDEF VER80}
ReallocMem(FRcvdPtr, FRcvBufSize, NewSize);
{$ELSE}
ReallocMem(FRcvdPtr, NewSize);
{$ENDIF}
FRcvBufSize := NewSize;
end;
{ Move edited data back to original buffer }
Move(Buf^, FRcvdPtr^, J);
FRcvdPtr[J] := #0;
FRcvdCnt := NewCnt;
Len := J - FRcvdCnt;
end;
finally
if BufSize > 0 then
FreeMem(Buf, BufSize);
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomLineWSocket.TriggerDataAvailable(Error : Word) : Boolean;
var
Cnt : Integer;
Len : Integer;
NewSize : Integer;
SearchFrom : Integer;
I : Integer;
Found : Boolean;
begin
if (not FLineMode) or (Length(FLineEnd) = 0) then begin
{ We are not in line mode }
Result := inherited TriggerDataAvailable(Error);
Exit;
end;
{ We are in line mode. We receive data ourself }
Result := TRUE;
Cnt := inherited GetRcvdCount;
if Cnt <= 0 then
Exit;
if (FRcvdCnt + Cnt + 1) > FRcvBufSize then begin
{ Current buffer is too small, allocate larger }
NewSize := FRcvdCnt + Cnt + 1;
{$IFDEF VER80}
ReallocMem(FRcvdPtr, FRcvBufSize, NewSize);
{$ELSE}
ReallocMem(FRcvdPtr, NewSize);
{$ENDIF}
FRcvBufSize := NewSize;
end;
Len := Receive(FRcvdPtr + FRcvdCnt, Cnt);
if Len <= 0 then
Exit;
FRcvdPtr[FRcvdCnt + Len] := #0;
if FLineEdit then
EditLine(Len)
else if FLineEcho then
Send(FRcvdPtr + FRcvdCnt, Len);
SearchFrom := FRcvdCnt - Length(FLineEnd);
if SearchFrom < 0 then
SearchFrom := 0;
FRcvdCnt := FRcvdCnt + Len;
while FLineMode do begin
Found := FALSE;
I := SearchFrom;
while I < (FRcvdCnt - Length(FLineEnd) + 1) do begin
if FRcvdPtr[I] = FLineEnd[1] then begin
Found := (StrLComp(@FRcvdPtr[I], @FLineEnd[1], Length(FLineEnd)) = 0);
if Found then
break; { Found the end of line marker }
end;
Inc(I);
end;
if not Found then
break;
FLineLength := I + Length(FLineEnd);
FLineReceivedFlag := TRUE;
{ We received a complete line. We need to signal it to application }
{ The application may not have a large buffer so we may need }
{ several events to read the entire line. In the meanwhile, the }
{ application may turn line mode off. }
while FLineMode and (FLineLength > 0) do begin
if not inherited TriggerDataAvailable(0) then
{ There is no handler installed }
FLineLength := 0;
end;
{ Move remaining data in front of buffer }
if FLineLength > 0 then begin
{ Line mode was turned off in the middle of a line read. }
{ We preserve unread line and other received data. }
Move(FRcvdPtr[I], FRcvdPtr[FLineLength],
FRcvdCnt - I);
FRcvdCnt := FRcvdCnt - I + FLineLength;
end
else begin
Move(FRcvdPtr[I + Length(FLineEnd)], FRcvdPtr[0],
FRcvdCnt - I - Length(FLineEnd));
FRcvdCnt := FRcvdCnt - I - Length(FLineEnd);
end;
FRcvdPtr[FRcvdCnt] := #0;
SearchFrom := 0;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomLineWSocket.TriggerSessionClosed(Error : Word);
begin
FLineReceivedFlag := TRUE;
if FRcvdPtr <> nil then begin
if FLineMode and (FRcvdCnt > 0) then begin
FLineLength := FRcvdCnt;
while FLineMode and (FLineLength > 0) do
inherited TriggerDataAvailable(0);
end;
FreeMem(FRcvdPtr, FRcvBufSize);
FRcvdPtr := nil;
FRcvBufSize := 0;
FRcvdCnt := 0;
end;
inherited TriggerSessionClosed(Error);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
X X X X X X X X X
X X X X X X X X X
X X X X X X X
X X X X X X X
X X X X X
X X X X X X X X
X X X X X X X X X
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSyncWSocket.InternalDataAvailable(
Sender : TObject;
Error : Word);
var
Len : Integer;
begin
SetLength(FLinePointer^, FLineLength);
Len := Receive(@FLinePointer^[1], FLineLength);
if Len <= 0 then
FLinePointer^ := ''
else
SetLength(FLinePointer^, Len);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomSyncWSocket.WaitUntilReady(var DoneFlag : Boolean) : Integer;
begin
Result := 0; { Suppose success }
FTimeStop := Integer(GetTickCount) + FTimeout;
while TRUE do begin
if DoneFlag then begin
Result := 0;
break;
end;
if ((FTimeout > 0) and (Integer(GetTickCount) > FTimeStop)) or
{$IFNDEF NOFORMS}
Application.Terminated or
{$ENDIF}
FTerminated then begin
{ Application is terminated or timeout occured }
Result := WSA_WSOCKET_TIMEOUT;
break;
end;
MessagePump;
{$IFNDEF VER80}
{ Do not use 100% CPU, but slow down transfert on high speed LAN }
Sleep(0);
{$ENDIF}
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TCustomSyncWSocket.Synchronize(
Proc : TWSocketSyncNextProc;
var DoneFlag : Boolean) : Integer;
begin
DoneFlag := FALSE;
if Assigned(Proc) then
Proc;
Result := WaitUntilReady(DoneFlag);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSyncWSocket.ReadLine(
Timeout : Integer; { seconds if positive, milli-seconds if negative }
var Buffer : String);
var
OldDataAvailable : TDataAvailable;
OldLineMode : Boolean;
Status : Integer;
begin
Buffer := '';
if FState <> wsConnected then begin
RaiseException('ReadLine failed: not connected');
Exit;
end;
{ Positive timeout means seconds. Negative means milli-seconds }
{ Null means 60 seconds. }
if TimeOut = 0 then
FTimeOut := 60000
else if TimeOut > 0 then
FTimeOut := Timeout * 1000
else
FTimeOut := -Timeout;
FLineReceivedFlag := FALSE;
FLinePointer := @Buffer;
{ Save existing OnDataAvailable handler and install our own }
OldDataAvailable := FOnDataAvailable;
FOnDataAvailable := InternalDataAvailable;
{ Save existing line mode and turn it on }
OldLineMode := FLineMode;
FLineMode := TRUE;
try
Status := Synchronize(nil, FLineReceivedFlag);
if Status = WSA_WSOCKET_TIMEOUT then begin
{ Sender didn't send line end within allowed time. Get all }
{ data available so far. }
if FRcvdCnt > 0 then begin
SetLength(Buffer, FRcvdCnt);
Move(FRcvdPtr^, Buffer[1], FRcvdCnt);
FRcvdCnt := 0;
end;
end;
{ Should I raise an exception to tell the application that }
{ some error occured ? }
finally
FOnDataAvailable := OldDataAvailable;
FLineMode := OldLineMode;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{$IFDEF VER80}
begin
IPList := TStringList.Create;
{
Delphi 1 has no finalization. When your application terminates, you
should add a call to WSocketUnloadWinsock to unload winsock from memory.
It is done automatically for you when the last TWSocket component is
destroyed but if you do any winsock call after that, you must call
WSocketUnloadWinsock yourself. It is safe to call WSocketUnloadWinsock
even if it has already been done.
}
{$ELSE}
initialization
IPList := TStringList.Create;
finalization
if Assigned(IPList) then begin
IPList.Destroy;
IPList := nil;
end;
WSocketUnloadWinsock;
{$ENDIF}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
end.