csocketmaster.cls

用VB编写的一个小程序

If ShowDebug Then Debug.Print "Winsock buffer size for sends: " & m_lngRecvBufferLen
If ShowDebug Then Debug.Print "Winsock buffer size for receives: " & m_lngSendBufferLen
End Sub

Public Sub GetData(ByRef data As Variant, Optional varType As Variant, Optional maxLen As Variant)

If m_enmProtocol = sckTCPProtocol Then
    If m_enmState <> sckConnected And Not m_blnAcceptClass Then
        Err.Raise sckBadState, "CSocketMaster.GetData", "Wrong protocol or connection state for the requested transaction or request"
        Exit Sub
    End If
Else
    If m_enmState <> sckOpen Then
        Err.Raise sckBadState, "CSocketMaster.GetData", "Wrong protocol or connection state for the requested transaction or request"
        Exit Sub
    End If
    If GetBufferLenUDP = 0 Then Exit Sub
End If

If Not IsMissing(maxLen) Then
    If IsNumeric(maxLen) Then
        If CLng(maxLen) < 0 Then
            Err.Raise sckInvalidArg, "CSocketMaster.GetData", "The argument passed to a function was not in the correct format or in the specified range."
        End If
    Else
        If m_enmProtocol = sckTCPProtocol Then
            maxLen = Len(m_strRecvBuffer)
        Else
            maxLen = GetBufferLenUDP
        End If
    End If
End If

Dim lngBytesRecibidos  As Long

lngBytesRecibidos = RecvData(data, False, varType, maxLen)
If ShowDebug Then Debug.Print "OK Bytes obtained from buffer: " & lngBytesRecibidos

End Sub

Public Sub PeekData(ByRef data As Variant, Optional varType As Variant, Optional maxLen As Variant)

If m_enmProtocol = sckTCPProtocol Then
    If m_enmState <> sckConnected Then
        Err.Raise sckBadState, "CSocketMaster.PeekData", "Wrong protocol or connection state for the requested transaction or request"
        Exit Sub
    End If
Else
    If m_enmState <> sckOpen Then
        Err.Raise sckBadState, "CSocketMaster.PeekData", "Wrong protocol or connection state for the requested transaction or request"
        Exit Sub
    End If
    If GetBufferLenUDP = 0 Then Exit Sub
End If

If Not IsMissing(maxLen) Then
    If IsNumeric(maxLen) Then
        If CLng(maxLen) < 0 Then
            Err.Raise sckInvalidArg, "CSocketMaster.PeekData", "The argument passed to a function was not in the correct format or in the specified range."
        End If
    Else
        If m_enmProtocol = sckTCPProtocol Then
            maxLen = Len(m_strRecvBuffer)
        Else
            maxLen = GetBufferLenUDP
        End If
    End If
End If

Dim lngBytesRecibidos  As Long

lngBytesRecibidos = RecvData(data, True, varType, maxLen)
If ShowDebug Then Debug.Print "OK Bytes obtained from buffer: " & lngBytesRecibidos
End Sub


'This function is to retrieve data from the buffer. If we are using TCP
'then the data is retrieved from a local buffer (m_strRecvBuffer). If we
'are using UDP the data is retrieved from winsock buffer.
'It can be called by two public methods of the class - GetData and PeekData.
'Behavior of the function is defined by the blnPeek argument. If a value of
'that argument is TRUE, the function returns number of bytes in the
'buffer, and copy data from that buffer into the data argument.
'If a value of the blnPeek is FALSE, then this function returns number of
'bytes received, and move data from the buffer into the data
'argument. MOVE means that data will be removed from the buffer.
Private Function RecvData(ByRef data As Variant, ByVal blnPeek As Boolean, Optional varClass As Variant, Optional maxLen As Variant) As Long

Dim blnMaxLenMiss   As Boolean
Dim blnClassMiss As Boolean
Dim strRecvData     As String
Dim lngBufferLen    As Long
Dim arrBuffer()     As Byte
Dim lngErrorCode    As Long

If m_enmProtocol = sckTCPProtocol Then
    lngBufferLen = Len(m_strRecvBuffer)
Else
    lngBufferLen = GetBufferLenUDP
End If

blnMaxLenMiss = IsMissing(maxLen)
blnClassMiss = IsMissing(varClass)

'Select type of data
If varType(data) = vbEmpty Then
    If blnClassMiss Then varClass = vbArray + vbByte
Else
    varClass = varType(data)
End If

'As stated on Winsock control documentation if the
'data type passed is string or byte array type then
'we must take into account maxLen argument.
'If it is another type maxLen is ignored.
If varClass = vbString Or varClass = vbArray + vbByte Then

    If blnMaxLenMiss Then 'if maxLen argument is missing
    
        If lngBufferLen = 0 Then
        
            RecvData = 0
        
            arrBuffer = StrConv("", vbFromUnicode)
            data = arrBuffer

            Exit Function
    
        Else
            
            RecvData = lngBufferLen
            arrBuffer = BuildArray(lngBufferLen, blnPeek, lngErrorCode)

        End If

    Else 'if maxLen argument is not missing

        If maxLen = 0 Or lngBufferLen = 0 Then

            RecvData = 0
        
            arrBuffer = StrConv("", vbFromUnicode)
            data = arrBuffer
            
            If m_enmProtocol = sckUDPProtocol Then
                EmptyBuffer
                Err.Raise WSAEMSGSIZE, "CSocketMaster.RecvData", GetErrorDescription(WSAEMSGSIZE)
            End If
            
            Exit Function
        
        ElseIf maxLen > lngBufferLen Then
            
            RecvData = lngBufferLen
            arrBuffer = BuildArray(lngBufferLen, blnPeek, lngErrorCode)

        Else
            
            RecvData = CLng(maxLen)
            arrBuffer() = BuildArray(CLng(maxLen), blnPeek, lngErrorCode)

        End If
    
    End If
        
End If

    Select Case varClass
    
    Case vbString
        Dim strdata As String
        strdata = StrConv(arrBuffer(), vbUnicode)
        data = strdata
    Case vbArray + vbByte
        data = arrBuffer
    Case vbBoolean
        Dim blnData As Boolean
        If LenB(blnData) > lngBufferLen Then Exit Function
        arrBuffer = BuildArray(LenB(blnData), blnPeek, lngErrorCode)
        RecvData = LenB(blnData)
        api_CopyMemory blnData, arrBuffer(0), LenB(blnData)
        data = blnData
    Case vbByte
        Dim bytData As Byte
        If LenB(bytData) > lngBufferLen Then Exit Function
        arrBuffer = BuildArray(LenB(bytData), blnPeek, lngErrorCode)
        RecvData = LenB(bytData)
        api_CopyMemory bytData, arrBuffer(0), LenB(bytData)
        data = bytData
    Case vbCurrency
        Dim curData As Currency
        If LenB(curData) > lngBufferLen Then Exit Function
        arrBuffer = BuildArray(LenB(curData), blnPeek, lngErrorCode)
        RecvData = LenB(curData)
        api_CopyMemory curData, arrBuffer(0), LenB(curData)
        data = curData
    Case vbDate
        Dim datData As Date
        If LenB(datData) > lngBufferLen Then Exit Function
        arrBuffer = BuildArray(LenB(datData), blnPeek, lngErrorCode)
        RecvData = LenB(datData)
        api_CopyMemory datData, arrBuffer(0), LenB(datData)
        data = datData
    Case vbDouble
        Dim dblData As Double
        If LenB(dblData) > lngBufferLen Then Exit Function
        arrBuffer = BuildArray(LenB(dblData), blnPeek, lngErrorCode)
        RecvData = LenB(dblData)
        api_CopyMemory dblData, arrBuffer(0), LenB(dblData)
        data = dblData
    Case vbInteger
        Dim intData As Integer
        If LenB(intData) > lngBufferLen Then Exit Function
        arrBuffer = BuildArray(LenB(intData), blnPeek, lngErrorCode)
        RecvData = LenB(intData)
        api_CopyMemory intData, arrBuffer(0), LenB(intData)
        data = intData
    Case vbLong
        Dim lngData As Long
        If LenB(lngData) > lngBufferLen Then Exit Function
        arrBuffer = BuildArray(LenB(lngData), blnPeek, lngErrorCode)
        RecvData = LenB(lngData)
        api_CopyMemory lngData, arrBuffer(0), LenB(lngData)
        data = lngData
    Case vbSingle
        Dim sngData As Single
        If LenB(sngData) > lngBufferLen Then Exit Function
        arrBuffer = BuildArray(LenB(sngData), blnPeek, lngErrorCode)
        RecvData = LenB(sngData)
        api_CopyMemory sngData, arrBuffer(0), LenB(sngData)
        data = sngData
    Case Else
        Err.Raise sckUnsupported, "CSocketMaster.RecvData", "Unsupported variant type."
       
    End Select

'if BuildArray returns an error is handled here
If lngErrorCode <> 0 Then
    Err.Raise lngErrorCode, "CSocketMaster.RecvData", GetErrorDescription(lngErrorCode)
End If

End Function

'Returns a byte array of Size bytes filled with incoming buffer data.
Private Function BuildArray(ByVal Size As Long, ByVal blnPeek As Boolean, ByRef lngErrorCode As Long) As Byte()
Dim strdata As String

If m_enmProtocol = sckTCPProtocol Then
        
    strdata = Left$(m_strRecvBuffer, CLng(Size))
    BuildArray = StrConv(strdata, vbFromUnicode)
                
    If Not blnPeek Then
        m_strRecvBuffer = Mid$(m_strRecvBuffer, Size + 1)
    End If

Else 'UDP protocol
    Dim arrBuffer() As Byte
    Dim lngResult As Long
    Dim udtSockAddr As sockaddr_in
    Dim lngFlags As Long
    
    If blnPeek Then lngFlags = MSG_PEEK
    
    ReDim arrBuffer(Size - 1)
    
    lngResult = api_recvfrom(m_lngSocketHandle, arrBuffer(0), Size, lngFlags, udtSockAddr, LenB(udtSockAddr))
    
    If lngResult = SOCKET_ERROR Then
        lngErrorCode = Err.LastDllError
    End If
    
    BuildArray = arrBuffer
    GetRemoteInfoFromSI udtSockAddr, m_lngRemotePort, m_strRemoteHostIP, m_strRemoteHost
    
End If
End Function

'Clean resolution system that is in charge of
'asynchronous hostname resolutions.
Private Sub CleanResolutionSystem()
Dim varAsynHandle As Variant

'cancel async resolutions if they're still running
For Each varAsynHandle In m_colWaitingResolutions
    api_WSACancelAsyncRequest varAsynHandle
    modSocketMaster.UnregisterResolution varAsynHandle
Next

'free memory buffer where resolution results are stored
FreeMemory
End Sub

Public Sub Listen()
If m_enmState <> sckClosed And m_enmState <> sckOpen Then
    Err.Raise sckInvalidOp, "CSocketMaster.Listen", "Invalid operation at current state"
End If

If Not SocketExists Then Exit Sub
If Not BindInternal Then Exit Sub

Dim lngResult As Long

lngResult = api_listen(m_lngSocketHandle, SOMAXCONN)

If lngResult = SOCKET_ERROR Then
    Dim lngErrorCode As Long
    lngErrorCode = Err.LastDllError
    Err.Raise lngErrorCode, "CSocketMaster.Listen", GetErrorDescription(lngErrorCode)
Else
    m_enmState = sckListening: If ShowDebug Then Debug.Print "STATE: sckListening"
End If

End Sub

Public Sub Accept(requestID As Long)
If m_enmState <> sckClosed Then
    Err.Raise sckInvalidOp, "CSocketMaster.Accept", "Invalid operation at current state"
End If

Dim lngResult As Long
Dim udtSockAddr As sockaddr_in
Dim lngErrorCode As Long

m_lngSocketHandle = requestID
m_enmProtocol = sckTCPProtocol
ProcessOptions

If Not modSocketMaster.IsAcceptRegistered(requestID) Then
    If IsSocketRegistered(requestID) Then
        Err.Raise sckBadState, "CSocketMaster.Accept", "Wrong protocol or connection state for the requested transaction or request"
    Else
        m_blnAcceptClass = True
        m_enmState = sckConnected: If ShowDebug Then Debug.Print "STATE: sckConnected"
        modSocketMaster.RegisterSocket m_lngSocketHandle, ObjPtr(Me), False
        Exit Sub
    End If
End If

Dim clsSocket As CSocketMaster
Set clsSocket = GetAcceptClass(requestID)
modSocketMaster.UnregisterAccept requestID

lngResult = api_getsockname(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr))

If lngResult = SOCKET_ERROR Then
    
    lngErrorCode = Err.LastDllError
    Err.Raise lngErrorCode, "CSocketMaster.Accept", GetErrorDescription(lngErrorCode)
    
Else

    m_lngLocalPortBind = IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port))
    m_strLocalIP = StringFromPointer(api_inet_ntoa(udtSockAddr.sin_addr))
    
End If

GetRemoteInfo m_lngSocketHandle, m_lngRemotePort, m_strRemoteHostIP, m_strRemoteHost
m_enmState = sckConnected: If ShowDebug Then Debug.Print "STATE: sckConnected"

If clsSocket.BytesReceived > 0 Then
    clsSocket.GetData m_strRecvBuffer
End If

modSocketMaster.Subclass_ChangeOwner requestID, ObjPtr(Me)

If Len(m_strRecvBuffer) > 0 Then RaiseEvent DataArrival(Len(m_strRecvBuffer))

If clsSocket.State = sckClosing Then
    m_enmState = sckClosing: If ShowDebug Then Debug.Print "STATE: sckClosing"
    RaiseEvent CloseSck
End If

Set clsSocket = Nothing
End Sub

'Retrieves remote info from a connected socket.
'If succeeds returns TRUE and loads the arguments.
'If fails returns FALSE and arguments are not loaded.
Private Function GetRemoteInfo(ByVal lngSocket As Long, ByRef lngRemotePort As Long, ByRef strRemoteHostIP As String, ByRef strRemoteHost As String) As Boolean
GetRemoteInfo = False
Dim lngResult As Long
Dim udtSockAddr As sockaddr_in

lngResult = api_getpeername(lngSocket, udtSockAddr, LenB(udtSockAddr))

If lngResult = 0 Then
    GetRemoteInfo = True
    GetRemoteInfoFromSI udtSockAddr, lngRemotePort, strRemoteHostIP, strRemoteHost
Else
   lngRemotePort = 0
   strRemoteHostIP = ""
   strRemoteHost = ""
End If
End Function

'Gets remote info from a sockaddr_in structure.
Private Sub GetRemoteInfoFromSI(ByRef udtSockAddr As sockaddr_in, ByRef lngRemotePort As Long, ByRef strRemoteHostIP As String, ByRef strRemoteHost As String)

'Dim lngResult As Long
'Dim udtHostent As HOSTENT

lngRemotePort = IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port))
strRemoteHostIP = StringFromPointer(api_inet_ntoa(udtSockAddr.sin_addr))
'lngResult = api_gethostbyaddr(udtSockAddr.sin_addr, 4&, AF_INET)

'If lngResult <> 0 Then
'    api_CopyMemory udtHostent, ByVal lngResult, LenB(udtHostent)
'    strRemoteHost = StringFromPointer(udtHostent.hName)
'Else
    m_strRemoteHost = ""
'End If

End Sub

'Returns winsock incoming buffer length from an UDP socket.
Private Function GetBufferLenUDP() As Long
Dim lngResult As Long
Dim lngBuffer As Long
lngResult = api_ioctlsocket(m_lngSocketHandle, FIONREAD, lngBuffer)

If lngResult = SOCKET_ERROR Then
    GetBufferLenUDP = 0
Else
    GetBufferLenUDP = lngBuffer
End If
End Function

'Empty winsock incoming buffer from an UDP socket.
Private Sub EmptyBuffer()
Dim B As Byte
api_recv m_lngSocketHandle, B, Len(B), 0&
End Sub