csocketmaster.cls

一个使用GPRS连接的WAP服务程序

        m_enmState = sckError: If ShowDebug Then Debug.Print "STATE: sckError"
        If ShowDebug Then Debug.Print "ERROR trying to create socket"
        SocketExists = False
        lngErrorCode = Err.LastDllError
        Dim blnCancelDisplay As Boolean
        blnCancelDisplay = True
        RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.SocketExists", "", 0, blnCancelDisplay)
        If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.SocketExists"
    Else
        
        If ShowDebug Then Debug.Print "OK Created socket: " & lngResult
        m_lngSocketHandle = lngResult
        'set and get some socket options
        ProcessOptions
        SocketExists = modSocketMaster.RegisterSocket(m_lngSocketHandle, ObjPtr(Me), True)
    
    End If
End If
End Function

'Tries to connect to RemoteHost if it was passed, or uses
'm_strRemoteHost instead. If it is a hostname tries to
'resolve it first.
Public Sub Connect(Optional RemoteHost As Variant, Optional RemotePort As Variant)
If m_enmState <> sckClosed Then
    Err.Raise sckInvalidOp, "CSocketMaster.Connect", "Invalid operation at current state"
End If

If Not IsMissing(RemoteHost) Then
        m_strRemoteHost = CStr(RemoteHost)
End If

'for some reason we get a GPF if we try to
'resolve a null string, so we replace it with
'an empty string
If m_strRemoteHost = vbNullString Then
    m_strRemoteHost = ""
End If

'check if RemotePort is a number between 1 and 65535
If Not IsMissing(RemotePort) Then
    If IsNumeric(RemotePort) Then
        If CLng(RemotePort) > 65535 Or CLng(RemotePort) < 1 Then
            Err.Raise sckInvalidArg, "CSocketMaster.Connect", "The argument passed to a function was not in the correct format or in the specified range."
        Else
            m_lngRemotePort = CLng(RemotePort)
        End If
    Else
        Err.Raise sckUnsupported, "CSocketMaster.Connect", "Unsupported variant type."
    End If
End If

'create a socket if there isn't one yet
If Not SocketExists Then Exit Sub

'If we are using UDP we just bind the socket and exit
'silently. Remember UDP is a connectionless protocol.
If m_enmProtocol = sckUDPProtocol Then
    If BindInternal Then
        m_enmState = sckOpen: If ShowDebug Then Debug.Print "STATE: sckOpen"
    End If
    Exit Sub
End If

'try to get a 32 bits long that is used to identify a host
Dim lngAddress As Long
lngAddress = ResolveIfHostname(m_strRemoteHost, destConnect)

'We've got two options here:
'1) m_strRemoteHost was an IP, so a resolution wasn't
'   necessary, and now lngAddress is a 32 bits long and
'   we proceed to connect.
'2) m_strRemoteHost was a hostname, so a resolution was
'   necessary and it's taking place right now. We leave
'   silently.

If lngAddress <> vbNull Then
    ConnectToIP lngAddress, 0
End If

End Sub

'When the system resolves a hostname in asynchronous way we
'call this function to decide what to do with the result.
Private Sub PostResolution(ByVal lngAsynHandle As Long, ByVal lngErrorCode As Long)
If m_enmState <> sckResolvingHost Then Exit Sub

Dim enmDestination As DestResolucion

'find out what the resolution destination was
enmDestination = m_colWaitingResolutions.Item("R" & lngAsynHandle)
'erase that record from the collection since we won't need it any longer
m_colWaitingResolutions.Remove "R" & lngAsynHandle

If lngErrorCode = 0 Then 'if there weren't errors trying to resolve the hostname
    
    m_enmState = sckHostResolved: If ShowDebug Then Debug.Print "STATE: sckHostResolved"
    
    Dim udtHostent As HOSTENT
    Dim lngPtrToIP As Long
    Dim arrIpAddress(1 To 4) As Byte
    Dim lngRemoteHostAddress As Long
    Dim Count As Integer
    Dim strIpAddress As String
    
    api_CopyMemory udtHostent, ByVal m_lngMemoryPointer, LenB(udtHostent)
    api_CopyMemory lngPtrToIP, ByVal udtHostent.hAddrList, 4
    api_CopyMemory arrIpAddress(1), ByVal lngPtrToIP, 4
    api_CopyMemory lngRemoteHostAddress, ByVal lngPtrToIP, 4
    
    'free memmory, won't need it any longer
    FreeMemory
    
    'We turn the 32 bits long into a readable string.
    'Note: we don't need this string. I put this here just
    'in case you need it.
    For Count = 1 To 4
        strIpAddress = strIpAddress & arrIpAddress(Count) & "."
    Next
        
    strIpAddress = Left$(strIpAddress, Len(strIpAddress) - 1)
    
    'Decide what to do with the result according to the destination
    Select Case enmDestination
    
    Case destConnect
        ConnectToIP lngRemoteHostAddress, 0
    
    End Select

Else 'there were errors trying to resolve the hostname

    'free buffer memory
    FreeMemory
    
    Select Case enmDestination
        
    Case destConnect
        ConnectToIP vbNull, lngErrorCode
        
    End Select

End If
End Sub

'This procedure is called by the WindowProc callback function
'from the modSocketMaster module. The lngEventID argument is an
'ID of the network event occurred for the socket. The lngErrorCode
'argument contains an error code only if an error was occurred
'during an asynchronous execution.
Private Sub PostSocket(ByVal lngEventID As Long, ByVal lngErrorCode As Long)

'handle any possible error
If lngErrorCode <> 0 Then
    m_enmState = sckError: If ShowDebug Then Debug.Print "STATE: sckError"
    Dim blnCancelDisplay As Boolean
    blnCancelDisplay = True
    RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.PostSocket", "", 0, blnCancelDisplay)
    If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.PostSocket"
    Exit Sub
End If

Dim udtSockAddr As sockaddr_in
Dim lngResult As Long
Dim lngBytesReceived As Long

Select Case lngEventID

'======================================================================

Case FD_CONNECT

    'Arrival of this message means that the connection initiated by the call
    'of the connect Winsock API function was successfully established.

    If ShowDebug Then Debug.Print "FD_CONNECT " & m_lngSocketHandle
    
    If m_enmState <> sckConnecting Then
        If ShowDebug Then Debug.Print "WARNING: Omitting FD_CONNECT"
        Exit Sub
    End If
    
    'Get the connection local end-point parameters
    lngResult = api_getpeername(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr))
        
    If lngResult = 0 Then
        m_lngRemotePort = modSocketMaster.IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port))
        m_strRemoteHostIP = StringFromPointer(api_inet_ntoa(udtSockAddr.sin_addr))
    End If
    
    m_enmState = sckConnected: If ShowDebug Then Debug.Print "STATE: sckConnected"
    RaiseEvent Connect

'======================================================================

Case FD_WRITE

    'This message means that the socket in a write-able
    'state, that is, buffer for outgoing data of the transport
    'service is empty and ready to receive data to send through
    'the network.
    
    If ShowDebug Then Debug.Print "FD_WRITE " & m_lngSocketHandle
    
    If m_enmState <> sckConnected Then
        If ShowDebug Then Debug.Print "WARNING: Omitting FD_WRITE"
        Exit Sub
    End If
    
    If Len(m_strSendBuffer) > 0 Then
        SendBufferedData
    End If
    
'======================================================================

Case FD_READ

    'Some data has arrived for this socket.

    If ShowDebug Then Debug.Print "FD_READ " & m_lngSocketHandle
    
    If m_enmProtocol = sckTCPProtocol Then
        
        If m_enmState <> sckConnected Then
            If ShowDebug Then Debug.Print "WARNING: Omitting FD_READ"
            Exit Sub
        End If
        
        'Call the RecvDataToBuffer function that move arrived data
        'from the Winsock buffer to the local one and returns number
        'of bytes received.
    
        lngBytesReceived = RecvDataToBuffer
    
        If lngBytesReceived > 0 Then
            RaiseEvent DataArrival(Len(m_strRecvBuffer))
        End If
    
    Else 'UDP protocol
        
        If m_enmState <> sckOpen Then
            If ShowDebug Then Debug.Print "WARNING: Omitting FD_READ"
            Exit Sub
        End If
        
        'If we use UDP we don't remove data from winsock buffer.
        'We just let the user know the amount received so
        'he/she can decide what to do.
        
        lngBytesReceived = GetBufferLenUDP
        
        If lngBytesReceived > 0 Then
            RaiseEvent DataArrival(lngBytesReceived)
        End If
        
        
        'Now the buffer is emptied no matter what the user
        'dicided to do with the received data
        EmptyBuffer
    End If
    
    
'======================================================================

Case FD_ACCEPT

    'When the socket is in a listening state, arrival of this message
    'means that a connection request was received. Call the accept
    'Winsock API function in oreder to create a new socket for the
    'requested connection.
  
    If ShowDebug Then Debug.Print "FD_ACCEPT " & m_lngSocketHandle
    If m_enmState <> sckListening Then
        If ShowDebug Then Debug.Print "WARNING: Omitting FD_ACCEPT"
        Exit Sub
    End If
    
    lngResult = api_accept(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr))
    
    If lngResult = INVALID_SOCKET Then
        lngErrorCode = Err.LastDllError
        Err.Raise lngErrorCode, "CSocketMaster.PostSocket", GetErrorDescription(lngErrorCode)
    Else
        'We assign a temporal instance of CSocketMaster to
        'handle this new socket until user accepts (or not)
        'the new connection
        modSocketMaster.RegisterAccept lngResult
        
        'We change remote info before firing ConnectionRequest
        'event so the user can see which host is trying to
        'connect.
        
        Dim lngTempRP As Long
        Dim strTempRHIP As String
        Dim strTempRH As String
        lngTempRP = m_lngRemotePort
        strTempRHIP = m_strRemoteHostIP
        strTempRH = m_strRemoteHost
        
        GetRemoteInfo lngResult, m_lngRemotePort, m_strRemoteHostIP, m_strRemoteHost
        
        If ShowDebug Then Debug.Print "OK Accepted socket: " & lngResult
        RaiseEvent ConnectionRequest(lngResult)
        
        'we return original info
        If m_enmState = sckListening Then
             m_lngRemotePort = lngTempRP
             m_strRemoteHostIP = strTempRHIP
             m_strRemoteHost = strTempRH
        End If
        
        'This is very important. If the connection wasn't accepted
        'we must close the socket.
        If IsAcceptRegistered(lngResult) Then
            api_closesocket lngResult
            modSocketMaster.UnregisterSocket lngResult
            modSocketMaster.UnregisterAccept lngResult
            If ShowDebug Then Debug.Print "OK Closed accepted socket: " & lngResult
        End If
    End If
    
'======================================================================
    
Case FD_CLOSE
    
    'This message means that the remote host is closing the conection
    
    If ShowDebug Then Debug.Print "FD_CLOSE " & m_lngSocketHandle
    
    If m_enmState <> sckConnected Then
        If ShowDebug Then Debug.Print "WARNING: Omitting FD_CLOSE"
        Exit Sub
    End If
    
    m_enmState = sckClosing: If ShowDebug Then Debug.Print "STATE: sckClosing"
    RaiseEvent CloseSck
    
End Select
End Sub

'Connect to a given 32 bits long ip
Private Sub ConnectToIP(ByVal lngRemoteHostAddress As Long, ByVal lngErrorCode As Long)

Dim blnCancelDisplay As Boolean

'Check and handle errors
If lngErrorCode <> 0 Then
    m_enmState = sckError: If ShowDebug Then Debug.Print "STATE: sckError"
    blnCancelDisplay = True
    RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.ConnectToIP", "", 0, blnCancelDisplay)
    If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.ConnectToIP"