wsocket_rtc.pas

Delphi快速开发Web Server

            NumVal := 0;
            { A dot must be followed by a digit }
            if (I >= Length(S)) or (not (S[I + 1] in ['0'..'9'])) then
                Exit;
        end
        else if S[I] in ['0'..'9'] then
            NumVal := NumVal * 10 + Ord(S[I]) - Ord('0')
        else begin
            { Not a digit nor a dot. Accept spaces until end of string }
            while (I <= Length(S)) and (S[I] = ' ') do
                Inc(I);
            if I <= Length(S) then
                Exit;  { Not a space, do not accept }
            break;     { Only spaces, accept        }
        end;
        Inc(I);
    end;
    { We must have exactly 3 dots }
    if (DotCount <> 3) or (NumVal > 255) then
        Exit;
    Result := TRUE;
end;

function WSocket_closesocket(s: TSocket): Integer;
  begin
  if FDllHandle=0 then
    raise EWinSockException.Create('WinSock not loaded.');
  Result:=_CloseSocket(S);
  end;

function WSocket_shutdown(s: TSocket; how: Integer): Integer;
  begin
  if FDllHandle=0 then
    raise EWinSockException.Create('WinSock not loaded.');
  Result:=_Shutdown(S,how);
  end;

function WSocket_htons(hostshort: u_short): u_short;
  begin
  if FDllHandle=0 then
    raise EWinSockException.Create('WinSock not loaded.');
  Result:=_htons(hostshort);
  end;

function WSocket_ntohs(netshort: u_short): u_short;
  begin
  if FDllHandle=0 then
    raise EWinSockException.Create('WinSock not loaded.');
  Result:=_ntohs(netshort);
  end;

function WSocket_ntohl(netlong: u_long): u_long;
  begin
  if FDllHandle=0 then
    raise EWinSockException.Create('WinSock not loaded.');
  Result:=_ntohl(netlong);
  end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.RaiseException(const Msg : String);
begin
    if Assigned(FOnError) then
        TriggerError
    else
        raise EWinSockException.Create(Msg);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.RaiseExceptionFmt(const Fmt : String; args : array of const);
begin
    if Assigned(FOnError) then
        TriggerError
    else
        raise EWinSockException.CreateFmt(Fmt, args);
end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function WSocketErrorDesc(error: integer) : string;
begin
    case error of
    0,
    WSABASEERR:
      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;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomWSocket.AssignDefaultValue;
begin
    FSrcLen:=0;

    FillChar(sin, Sizeof(sin), 0);
    sin.sin_family     := AF_INET;
    FAddrFormat        := PF_INET;

    FPortAssigned      := FALSE;
    FPortResolved      := FALSE;

    FAddrAssigned      := FALSE;
    FAddrResolved      := FALSE;

    FLocalPortResolved := FALSE;

    FLocalPortStr      := '0';
    FLocalAddr         := '0.0.0.0';

    FHSocket           := INVALID_SOCKET;
    FSelectEvent       := 0;
    FState             := wsClosed;

    FSentOut           := 0;
    FSentFlag          := TRUE; // message will be sent from Windows
    FReadyToSend       := FALSE; // we are not yet ready to send
    bAllSent           := TRUE;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ All exceptions *MUST* be handled. If an exception is not handled, the     }
{ application will be shut down !                                           }
procedure TCustomWSocket.HandleBackGroundException(E: Exception);
var
    CanAbort : Boolean;
begin
    CanAbort := TRUE;
    { First call the error event handler, if any }
    if Assigned(FOnBgException) then begin
        try
          FOnBgException(Self, E, CanAbort);
        except
          on E:Exception do
            Log('FOnBgException',E);
        end;
    end;
    { Then abort the socket }
    if CanAbort then begin
        try
            Abort;
        except
          on E:Exception do
            Log('Abort',E);
        end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This procedure handle all messages for TWSocket. All exceptions must be   }
{ handled or the application will be shutted down !                         }
{ If WndProc is overriden in descendent components, then the same exception }
{ handling *MUST* be setup because descendent component code is executed    }
{ before the base class code.                                               }
procedure TCustomWSocket.WndProc(var MsgRec: TMessage);
  begin
  with MsgRec do
    begin
    if (Msg >= WM_ASYNCSELECT_FIRST) and (Msg <= WM_ASYNCSELECT_LAST) then
      WMASyncSelect(MsgRec)
    else if Msg = WM_CLOSE_DELAYED then
      Call_CloseDelayed
    else if Msg = WM_WSOCKET_RELEASE then
      Call_Release
    else
      Result := DefWindowProc(Handle, Msg, wParam, LParam);
    end;
  end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This function is a callback function. It means that it is called by       }
{ windows. This is the very low level message handler procedure setup to    }
{ handle the message sent by windows (winsock) to handle messages.          }

// D.Tkalcec -> modified to work with 1 handle for all connections.
function RtcSocketWindowProc(ahWnd   : HWND;
                           auMsg   : LongWord;
                           awParam : WPARAM;
                           alParam : LPARAM): Integer; stdcall;
  var
    Obj    : TObject;
    MsgRec : TMessage;
    Sock   : TSocket;
    iStatus: Integer;
    Hdl: HWND;
    Msg: LongWord;
  begin
  try
    case auMsg of
      WM_TIMER:
        begin
        if (awParam<>0) then
          Obj:=rtcGetTimer(awParam)
        else
          Obj:=nil;

        if (Obj<>nil) and (Obj is TRtcTimer) then
          begin
          try
            TRtcTimer.Timer(Obj);
          except
            on E:Exception do
              Log('WM_TIMER',E);
            end;
          Result := 0;
          end
        else
          Result := DefWindowProc(ahWnd, auMsg, awParam, alParam);
        end;

      WM_TSOCKET_CLOSE:
        begin
        Sock:=awParam;
        try
          iStatus := _closesocket(Sock);
          if iStatus<>0 then
            if WSAGetLastError = WSAEWOULDBLOCK then
              begin
              if LOG_SOCKET_ERRORS then
                Log('WM_TSOCKET_CLOSE: WM_TSOCKET_CLOSE would block.');
              _shutdown(Sock,SD_BOTH);
              if not PostMessage(ahWnd,WM_TSOCKET_CLOSE,Sock,0) then // can not post message?
                _closesocket(Sock);
              end;
        except
          on E:Exception do
            Log('WM_TSOCKET_CLOSE',E);
          end;
        Result:=0;
        end;

      WM_ASYNCSELECT_FIRST .. WM_ASYNCSELECT_LAST:
        begin
        Sock:=awParam;

        Hdl:=0;
        Msg:=0;
        Obj:=nil;

        rtcEnterSocket;
        try
          if (Sock<>0) and (Sock<>INVALID_SOCKET) then
            begin
            Obj:=rtcGetSocket(Sock);
            if Obj<>nil then
              begin
              if Obj is TWSocket then
                begin
                Hdl:=TWSocket(Obj).Handle;
                Msg:=TWSocket(Obj).MessageCode;
                end
              else
                Obj:=nil;
              end;
            end;
        finally
          rtcLeaveSocket;
          end;

        if Obj<>nil then
          begin
          if (Hdl=ahWnd) and (Msg=auMsg) then
            begin
            MsgRec.Msg    := auMsg;
            MsgRec.WParam := awParam;
            MsgRec.LParam := alParam;
            try
              TWSocket(Obj).WndProc(MsgRec);
            except
              on E:Exception do
                begin
                Log('WM_ASYNCSELECT(wparam='+IntToStr(awParam)+', lparam='+IntToStr(alParam)+')',E);
                rtcEnterSocket;
                try
                  Obj:=rtcGetSocket(Sock);
                  if Obj<>nil then
                    if Obj is TWSocket then
                      try
                        TWSocket(Obj).HandleBackGroundException(E);
                      except
                        on E:Exception do
                          Log('HandleBgException',E);
                        end;
                finally
                  rtcLeaveSocket;
                  end;
                end;
              end;
            Result := MsgRec.Result;
            end
          else
            begin
            if LOG_MESSAGE_ERRORS then
              Log('MESSAGE ERROR: hdl='+IntToStr(ahWnd)+',msg='+IntToStr(auMsg)+',sock='+IntToStr(awParam)+',code='+IntToStr(alParam)+' received for Object where hdl='+IntToStr(Hdl)+',msg='+IntToStr(Msg));
            Result := 0; // Old Message -> IGNORE! // DefWindowProc(ahWnd, auMsg, awParam, alParam);
            end;
          end
        else
          begin
          // Log('MESSAGE ERROR: hdl='+IntToStr(ahWnd)+',msg='+IntToStr(auMsg)+',sock='+IntToStr(awParam)+',code='+IntToStr(alParam)+' received for non-existing Object.');
          Result := 0; // Old Message -> IGNORE! // DefWindowProc(ahWnd, auMsg, awParam, alParam);
          end;
        end;