wsocket_rtc.pas

Delphi快速开发Web Server

      WM_CLOSE_DELAYED,
      WM_WSOCKET_RELEASE:
        begin
        Obj:=TObject(awParam);

        if (Obj<>nil) and (Obj is TWSocket) then
          begin
          if TWSocket(Obj).Handle=ahWnd then
            begin
            MsgRec.Msg    := auMsg;
            MsgRec.WParam := awParam;
            MsgRec.LParam := alParam;
            try
              TWSocket(Obj).WndProc(MsgRec);
            except
              on E:Exception do
                Log('WM_RELEASE(wparam='+IntToStr(awParam)+', lparam='+IntToStr(alParam)+')',E);
              end;
            Result := MsgRec.Result;
            end
          else
            begin
            // Log('WSOCKET ERROR! Want Handle '+IntToStr(TWSocket(Obj).Handle)+' got handle: '+IntToStr(ahWnd));
            Result := 0; // Old Message, IGNORE! // DefWindowProc(ahWnd, auMsg, awParam, alParam);
            end;
          end
        else
          Result := 0; // Old Message, IGNORE! // DefWindowProc(ahWnd, auMsg, awParam, alParam);
        end;
      else
        Result := DefWindowProc(ahWnd, auMsg, awParam, alParam);
      end;
  except
    on E:Exception do
      begin
      Log('WndProc_MAIN(Wnd='+IntToStr(ahWnd)+', '+
                       'Msg='+IntToStr(auMsg)+', '+
                       'wParam='+IntToStr(awParam)+', '+
                       'lParam='+IntToStr(alParam)+')',E);
      Result:=0;
      end;
    end;
  end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This global variable is used to store the windows class characteristic    }
{ and is needed to register the window class used by TWSocket               }
var
    XSocketRegistered:boolean=False;

{$IFDEF FPC}
    RtcSocketWindowClass: TWndClass = (
        style         : 0;
        lpfnWndProc   : WndProc(RtcSocketWindowProc);
        cbClsExtra    : 0;
        cbWndExtra    : SizeOf(Pointer);
        hInstance     : 0;
        hIcon         : 0;
        hCursor       : 0;
        hbrBackground : 0;
        lpszMenuName  : nil;
        lpszClassName : 'RtcSocketWindowClass');
{$ELSE}
    RtcSocketWindowClass: TWndClass = (
        style         : 0;
        lpfnWndProc   : @RtcSocketWindowProc;
        cbClsExtra    : 0;
        cbWndExtra    : SizeOf(Pointer);
        hInstance     : 0;
        hIcon         : 0;
        hCursor       : 0;
        hbrBackground : 0;
        lpszMenuName  : nil;
        lpszClassName : 'RtcSocketWindowClass');
{$ENDIF}

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Unregister the window class use by the component. This is necessary to do }
{ so from a DLL when the DLL is unloaded (that is when DllEntryPoint is     }
{ called with dwReason equal to DLL_PROCESS_DETACH.                         }
procedure WSocketUnregisterClass;
  begin
  if XSocketRegistered then // D.Tkalcec
    begin
    Windows.UnregisterClass(RtcSocketWindowClass.lpszClassName, HInstance);
    XSocketRegistered:=False; // D.Tkalcec
    end;
  end;

function WSocketRegisterClass:integer;
  var
    TempClass       : TWndClass;
    ClassRegistered : BOOL;
  begin
  Result:=0;

  if not XSocketRegistered then // D.Tkalcec
    begin
    { Check if the window class is already registered                   }
    RtcSocketWindowClass.hInstance := HInstance;
    ClassRegistered := GetClassInfo(HInstance,
                                    RtcSocketWindowClass.lpszClassName,
                                    TempClass);
    if not ClassRegistered then begin
       { Not yet registered, do it right now                            }
       Result := Windows.RegisterClass(RtcSocketWindowClass);
       if Result = 0 then
           Exit;
       end;
    XSocketRegistered:=True; // D.Tkalcec
    end
  else
    Result:=1;
  end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.AllocateSocketHWnd;
begin
    FWindowHandle := rtcGetHWND(MultiThreaded);
    FMessageCode  := 0;

    if FWindowHandle = 0 then
        RaiseException('Cannot create a hidden window for TWSocket');
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.DeallocateSocketHWnd;
begin
    if FWindowHandle = 0 then Exit;

    rtcReturnHWND(FWindowHandle);

    FWindowHandle := 0;
    FMessageCode := 0;
end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TCustomWSocket.Create(AOwner: TComponent);
begin
    inherited Create(AOwner);

    Protocol := spTcp;

    FWindowHandle:=0;

    FBufList        := TXList.Create(32);
    FBufSize        := WSOCK_MAX_SEND_SIZE;           { Default buffer size }
    ListenBacklog   := 200;

    FMultiCastIpTTL := IP_DEFAULT_MULTICAST_TTL;

    AssignDefaultValue;

end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TCustomWSocket.Destroy;
begin
    rtcRemoveSocket(self);

    try
        CancelDnsLookup;             { Cancel any pending dns lookup      }
    except
        { Ignore any exception here }
    end;

    if FState <> wsClosed then       { Close the socket if not yet closed }
        Close;

    DeleteBufferedData;
    if Assigned(FBufList) then begin
        FBufList.Free;
        FBufList := nil;
    end;

    DeallocateSocketHWnd;

    inherited Destroy;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.Dup(NewHSocket : TSocket);
  var
    iStatus : Integer;
    optval,
    optlen : integer;
  begin
  if (NewHSocket = 0) or (NewHSocket = INVALID_SOCKET) then
    begin
    FLastError:=WSAEINVAL;
    SocketError('Dup');
    Exit;
    end;

  if FState <> wsClosed then
    begin
      rtcRemoveSocket(self);

      iStatus := _closesocket(FHSocket);
      FHSocket := INVALID_SOCKET;
      if iStatus <> 0 then
        begin
        FLastError:=WSAGetLastError;
        SocketError('Dup (closesocket)');
        Exit;
        end;
      ChangeState(wsClosed);
    end;

  FHsocket := NewHSocket;

  // Check SEND Buffer size
  optval := 0;
  optlen := sizeof(optval);
  iStatus := _getsockopt(FHsocket, SOL_SOCKET,
                                             SO_SNDBUF, @optval, optlen);
  if iStatus <> 0 then
    begin
    FLastError:=WSAGetLastError;
    SocketError('getsockopt(SOL_SOCKET, SO_SNDBUF)');
    Exit;
    end;

  if optlen=sizeof(optval) then
    begin
    BufSize:=optval;
    if (BufSize=0) or (BufSize>WSOCK_MAX_SEND_SIZE) then
      BufSize:=WSOCK_MAX_SEND_SIZE;
    end
  else
    BufSize:=WSOCK_MAX_SEND_SIZE;

  SetLingerOption;

  // D.Tkalcec
  rtcStoreSocket(self, FHSocket);
  FMessageCode := WM_ASYNCSELECT_FIRST + rtcGetNextMsgCode(Handle) - 1;

  FSelectEvent := FD_READ or FD_WRITE or FD_CLOSE;

  iStatus      := _WSAASyncSelect(FHSocket, Handle,
                                                   FMessageCode, FSelectEvent);
  if iStatus <> 0 then
    begin
    FLastError:=WSAGetLastError;
    SocketError('WSAAsyncSelect');
    Exit;
    end;

  DupConnected;
  end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.DupConnected;
  begin
  ChangeState(wsConnected);
  end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Get the number of char received and waiting to be read                    }
function TCustomWSocket.GetRcvdCount : LongInt;
  var
    Temp : u_long;
    Res : integer;
  begin
  if csDesigning in ComponentState then
    begin
    Result := -1;
    Exit;
    end;
  Res:=_ioctlsocket(FHSocket, FIONREAD, Temp);
  if Res = SOCKET_ERROR then
    begin
    FLastError:=WSAGetLastError;
    if (FLastError=WSAEWOULDBLOCK) or
       (FLastError=WSABASEERR) then
      begin
      if LOG_SOCKET_ERRORS then
        Log('RCV COUNT would block. Socket '+IntToStr(FHSocket)+'.');
      Result:=0;
      end
    else
      begin
      Result:=-1;
      if LOG_SOCKET_ERRORS then
        Log('RCV COUNT err ['+WSocketErrorDesc(FLastError)+'] (abort). Socket '+IntToStr(FHSocket)+'.');
      end;
    end
  else
    Result := LongInt(Temp);
  end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.ChangeState(NewState : TSocketState);
var
    OldState : TSocketState;
begin
    OldState := FState;
    FState   := NewState;
    if OldState <> NewState then       { 20030226 }
      TriggerChangeState(OldState, NewState);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ DoRecv is a simple wrapper around winsock recv function to make it        }
{ a virtual function.                                                       }
function TCustomWSocket.DoRecv(
      var Buffer;
      BufferSize : Integer;
      Flags      : Integer) : Integer;
  begin
    if (Protocol=spUdp) then
      begin
      FSrcLen := SizeOf(FSrc);
      Result := _recvfrom(FHSocket, Buffer, BufferSize, Flags, FSrc, FSrcLen);
      { If we received the requested size, we may need to receive more }
      FRcvdFlag := (Result >= BufferSize);
      end
    else
      begin
      Result := _recv(FHSocket, Buffer, BufferSize, Flags);
      { If we received the requested size, we may need to receive more }
      FRcvdFlag := (Result >= BufferSize);
      end;
    if Result>0 then
      TriggerDataIn(Result);
  end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ The socket is non-blocking, so this routine will only receive as much     }
{ data as it is available.                                                  }
function TCustomWSocket.Receive(var Buffer; BufferSize: integer) : integer;
  begin
  Result := DoRecv(Buffer, BufferSize, 0);
  if Result < 0 then
    begin
    FLastError := WSAGetLastError;
    if (FLastError=WSAEWOULDBLOCK) or
       (FLastError=WSABASEERR) then
      begin
      // Log('RECEIVE would block, Socket '+IntToStr(FHSocket)+'.');
      Result:=0;
      end
    else
      begin
      if LOG_SOCKET_ERRORS then
        Log('RECEIVE err ['+WSocketErrorDesc(FLastError)+'], Socket '+IntToStr(FHSocket)+'.');
      if Protocol=spTcp then
        Result:=0;
      // Close;
      // raise EWinSockException.Create('Can not receive. Error #'+IntToStr(FLastError)+': '+WSocketErrorDesc(FLastError));
      end;
    end
  else if Result=0 then
    begin
    FLastError:=WSAECONNABORTED;
    if Protocol=spTcp then
      Result:=0;
    // Log('RECEIVE 0 bytes (abort), Socket '+IntToStr(FHSocket)+'.');
    // Close;
    // raise EWinSockException.Create('Can not receive. Error #'+IntToStr(FLastError)+': '+WSocketErrorDesc(FLastError));
    end;
  {else
    begin
    if Result=BufferSize then
      Log('RECEIVE '+IntToStr(Result)+' bytes, Socket '+IntToStr(FHSocket)+'.')
    else
      Log('RECEIVE LESS '+IntToStr(Result)+'/'+IntToStr(BufferSize)+' bytes, Socket '+IntToStr(FHSocket)+'.');
    end;}
  end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Receive as much data as possible into a string                            }
{ You should avoid this function and use Receive. Using string will be      }
{ much slower because data will be copied several times.                    }
{ ReceiveStr will *NOT* wait for a line to be received. It just read        }
{ already received characters and return them as a string.                  }
function TCustomWSocket.ReceiveStr : string;
  var
    lCount : LongInt;
  begin
  lCount := GetRcvdCount;

  if LCount < 0 then
    begin  { GetRcvdCount returned an error }
    SetLength(Result, 0);
    Exit;
    end;

  if lCount = 0 then        { GetRcvdCount say nothing, will try anyway }
    LCount := 512;        { some reasonable arbitrary value           }

  SetLength(Result, lCount);
  lCount := Receive(Result[1], lCount);
  if lCount > 0 then
    SetLength(Result, lCount)
  else
    SetLength(Result, 0);
  end;