Salut Steve Batson !
-------------WSocket.Pas part 3/5 -------------
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function SearchChar(Data : PChar; Len : Integer; Ch : Char) : PChar;
begin
while Len > 0 do begin
Len := Len - 1;
if Data^ = Ch then begin
Result := Data;
exit;
end;
Data := Data + 1;
end;
Result := nil;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TWSocket.TryToSend;
var
oBuffer : TBuffer;
Len : Integer;
Count : Integer;
Data : Pointer;
LastError : Integer;
p : PChar;
bMore : Boolean;
begin
if (FBufList.Count = 0) or { Nothing to send *}
(bMoreFlag and (nMoreCnt >= nMoreMax)) then { Waiting more signal *}
exit;
bMore := TRUE;
while bMore do begin
oBuffer := FBufList.First;
Data := oBuffer.Peek(Len);
if Len <= 0 then begin
{ Buffer is empty }
if FBufList.Count <= 1 then begin
{ Every thing has been sent }
bAllSent := TRUE;
bMore := FALSE;
end
else begin
oBuffer.Free;
FBufList.Delete(1);
FBufList.Pack;
end;
end
else begin
if bMoreFlag then begin
p := SearchChar(Data, Len, #10);
if Assigned(p) then begin
len := p - PChar(Data) + 1;
nMoreCnt := nMoreCnt + 1;
if nMoreCnt >= nMoreMax then
bMore := FALSE;
end;
end;
Count := WinSock.Send(FHSocket, Data^, Len, 0);
if Count = 0 then
bMore := FALSE { Closed by remote }
else if count = SOCKET_ERROR then begin
LastError := WSAGetLastError;
if (LastError = WSAECONNRESET) or (LastError = WSAENOTSOCK)
then begin
Close;
end
else if LastError WSAEWOULDBLOCK then begin
Application.MessageBox('TryToSend failed',
'WINSOCK ERROR',
mb_OKCancel + mb_DefButton1);
end;
bMore := FALSE;
end
else begin
oBuffer.Remove(Count);
if Count < Len then begin
{ Could not write as much as we wanted. Stop sending }
bWrite := FALSE;
bMore := FALSE;
end;
end;
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Return -1 if error, else return number of byte written }
function TWSocket.Send(Data : Pointer; Len : Integer) : integer;
var
oBuffer : TBuffer;
cWritten : Integer;
bMore : Boolean;
begin
if FState Connected then begin
Application.MessageBox('Send: Socket not connected',
'WINSOCK ERROR',
mb_OKCancel + mb_DefButton1);
Result := -1;
exit;
end;
if Len <= 0 then begin
Result := 0;
exit;
end;
bAllSent := FALSE;
if FBufList.Count = 0 then begin
oBuffer := TBuffer.Create;
FBufList.Add(oBuffer);
end
else
oBuffer := FBufList.Last;
bMore := TRUE;
while bMore do begin
cWritten := oBuffer.Write(Data, Len);
if cWritten >= Len then
bMore := FALSE
else begin
Len := Len - cWritten;
if Len < 0 then
bMore := FALSE
else begin
oBuffer := TBuffer.Create;
FBufList.Add(oBuffer);
end;
end;
end;
TryToSend;
Result := Len;
if bAllSent then begin
{ We post a message to fire the FD_WRITE message wich in turn will }
{ fire the OnDataSent event. We cannot fire the event ourself }
{ because the event handler will eventually call send again. }
{ Sending the message prevent recursive call and stack overflow. }
{ The PostMessage function posts (places) a message in a window's }
{ message queue and then returns without waiting for the }
{ corresponding window to process the message. The message will be }
{ seen and routed by Delphi a litle later, when we will be out of }
{ the send function. }
PostMessage(Handle,
WM_ASYNCSELECT,
FHSocket,
MakeLong(FD_WRITE, 0));
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Return -1 if error, else return number of byte written }
function TWSocket.SendStr(Str : String) : integer;
begin
Result := Send(@Str[1], Length(Str));
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TWSocket.WMASyncSelect(var msg: TMessage);
var
Check : Word;
lCount : LongInt;
bMore : Boolean;
begin
if FPaused then
exit;
Check := msg.lParamLo and FD_CONNECT;
if Check 0 then begin
ChangeState(Connected);
if Assigned(FSessionConnected) then
FSessionConnected(Self, msg.lParamHi);
if (msg.lParamHi 0) and (FState Closed) then
Close;
end;
Check := msg.lParamLo and FD_READ;
if Check 0 then begin
bMore := TRUE;
while bMore do begin
if ReadLineFlag then
ReadLineReceive
else if Assigned(FDataAvailable) then
FDataAvailable(Self, msg.lParamHi);
{* Check if we have something new arrived, if yes, process it *}
if IoctlSocket(FHSocket, FIONREAD, lCount) = SOCKET_ERROR then
begi
n
FLastError := WSAGetLastError;
bMore := FALSE;
end
else if lCount = 0 then
bMore := FALSE;
end;
end;
Check := msg.lParamLo and FD_WRITE;
if Check 0 then begin
TryToSend;
if bAllSent and Assigned(FDataSent) then
FDataSent(Self, msg.lParamHi);
end;
Check := msg.lParamLo and FD_ACCEPT;
if Check 0 then begin
if Assigned(FSessionAvailable) then
FSessionAvailable(Self, msg.lParamHi);
end;
Check := msg.lParamLo and FD_CLOSE;
if Check 0 then begin
{* Check if we have something arrived, if yes, process it *}
if IoctlSocket(FHSocket, FIONREAD, lCount) SOCKET_ERROR then begin
if lCount > 0 then begin
if ReadLineFlag then
ReadLineReceive
else if Assigned(FDataAvailable) then
FDataAvailable(Self, msg.lParamHi);
end;
end;
if Assigned(FSessionClosed) then
FSessionClosed(Self, msg.lParamHi);
if FState Closed then
Close;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TWSocket.SetProto(Proto : String);
var
szProto : array [0..31] of char;
Ppe : Pprotoent;
begin
FProtoAssigned := TRUE;
Proto := Trim(Proto);
if IsDigit(Proto[1]) then
FProto := atoi(Proto)
else begin
StrPCopy(szProto, Proto);
ppe := GetProtoByName(szProto);
if Ppe = nil then
FProtoAssigned := FALSE
else
FProto := ppe^.p_proto;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TWSocket.GetProto : String;
var
Ppe : Pprotoent;
begin
if not FProtoAssigned then
Result := '' {'not assigned'}
else begin
ppe := GetProtoByNumber(FProto);
if Ppe = nil then
Result := 'not found'
else begin
SetLength(Result, StrLen(ppe^.p_name));
StrCopy(@Result[1], ppe^.p_name);
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
----------- End of WSocket.Pas part 3/5 --------------
Amiti‚s,
{-Francois Piette-}
--- SvFido 1.32
---------------
* Origin: OverByte BBS (Embourg-Belgium) 32-41-651395 V-FAST (2:293/2202)
|