modsocketmaster.bas

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

    Case WSAEADDRINUSE
        GetErrorDescription = "Address already in use."
    Case WSAEADDRNOTAVAIL
        GetErrorDescription = "Cannot assign requested address."
    Case WSAEAFNOSUPPORT
        GetErrorDescription = "Address family not supported by protocol family."
    Case WSAEALREADY
        GetErrorDescription = "Operation already in progress."
    Case WSAECONNABORTED
        GetErrorDescription = "Software caused connection abort."
    Case WSAECONNREFUSED
        GetErrorDescription = "Connection refused."
    Case WSAECONNRESET
        GetErrorDescription = "Connection reset by peer."
    Case WSAEDESTADDRREQ
        GetErrorDescription = "Destination address required."
    Case WSAEFAULT
        GetErrorDescription = "Bad address."
    Case WSAEHOSTUNREACH
        GetErrorDescription = "No route to host."
    Case WSAEINPROGRESS
        GetErrorDescription = "Operation now in progress."
    Case WSAEINTR
        GetErrorDescription = "Interrupted function call."
    Case WSAEINVAL
        GetErrorDescription = "Invalid argument."
    Case WSAEISCONN
        GetErrorDescription = "Socket is already connected."
    Case WSAEMFILE
        GetErrorDescription = "Too many open files."
    Case WSAEMSGSIZE
        GetErrorDescription = "Message too long."
    Case WSAENETDOWN
        GetErrorDescription = "Network is down."
    Case WSAENETRESET
        GetErrorDescription = "Network dropped connection on reset."
    Case WSAENETUNREACH
        GetErrorDescription = "Network is unreachable."
    Case WSAENOBUFS
        GetErrorDescription = "No buffer space available."
    Case WSAENOPROTOOPT
        GetErrorDescription = "Bad protocol option."
    Case WSAENOTCONN
        GetErrorDescription = "Socket is not connected."
    Case WSAENOTSOCK
        GetErrorDescription = "Socket operation on nonsocket."
    Case WSAEOPNOTSUPP
        GetErrorDescription = "Operation not supported."
    Case WSAEPFNOSUPPORT
        GetErrorDescription = "Protocol family not supported."
    Case WSAEPROCLIM
        GetErrorDescription = "Too many processes."
    Case WSAEPROTONOSUPPORT
        GetErrorDescription = "Protocol not supported."
    Case WSAEPROTOTYPE
        GetErrorDescription = "Protocol wrong type for socket."
    Case WSAESHUTDOWN
        GetErrorDescription = "Cannot send after socket shutdown."
    Case WSAESOCKTNOSUPPORT
        GetErrorDescription = "Socket type not supported."
    Case WSAETIMEDOUT
        GetErrorDescription = "Connection timed out."
    Case WSAEWOULDBLOCK
        GetErrorDescription = "Resource temporarily unavailable."
    Case WSAHOST_NOT_FOUND
        GetErrorDescription = "Host not found."
    Case WSANOTINITIALISED
        GetErrorDescription = "Successful WSAStartup not yet performed."
    Case WSANO_DATA
        GetErrorDescription = "Valid name, no data record of requested type."
    Case WSANO_RECOVERY
        GetErrorDescription = "This is a nonrecoverable error."
    Case WSASYSNOTREADY
        GetErrorDescription = "Network subsystem is unavailable."
    Case WSATRY_AGAIN
        GetErrorDescription = "Nonauthoritative host not found."
    Case WSAVERNOTSUPPORTED
        GetErrorDescription = "Winsock.dll version out of range."
    Case Else
        GetErrorDescription = "Unknown error."
End Select

End Function

'Create a window that is used to capture sockets messages.
'Returns 0 if it has success.
Private Function CreateWinsockMessageWindow() As Long
m_lngWindowHandle = api_CreateWindowEx(0&, "STATIC", "SOCKET_WINDOW", 0&, 0&, 0&, 0&, 0&, 0&, 0&, App.hInstance, ByVal 0&)

If m_lngWindowHandle = 0 Then
    CreateWinsockMessageWindow = sckOutOfMemory
    Exit Function
Else
    CreateWinsockMessageWindow = 0
    Debug.Print "OK Created winsock message window " & m_lngWindowHandle
End If
End Function

'Destroy the window that is used to capture sockets messages.
'Returns 0 if it has success.
Private Function DestroyWinsockMessageWindow() As Long
DestroyWinsockMessageWindow = 0

If m_lngWindowHandle = 0 Then
    Debug.Print "WARNING lngWindowHandle is ZERO"
    Exit Function
End If
    
Dim lngResult As Long

lngResult = api_DestroyWindow(m_lngWindowHandle)
    
If lngResult = 0 Then
    DestroyWinsockMessageWindow = sckOutOfMemory
    Err.Raise sckOutOfMemory, "modSocketMaster.DestroyWinsockMessageWindow", "Out of memory"
Else
    Debug.Print "OK Destroyed winsock message window " & m_lngWindowHandle
    m_lngWindowHandle = 0
End If
    
End Function

'When a socket needs to resolve a hostname in asynchronous way
'it calls this function. If it has success it returns a nonzero
'number that represents the async task handle and register this
'number in the TableA list.
'Returns 0 if it fails.
Public Function ResolveHost(ByVal strHost As String, ByVal lngHOSTENBuf As Long, ByVal lngObjectPointer As Long) As Long
Dim lngAsynHandle As Long
lngAsynHandle = api_WSAAsyncGetHostByName(m_lngWindowHandle, RESOLVE_MESSAGE, strHost, ByVal lngHOSTENBuf, MAXGETHOSTSTRUCT)
If lngAsynHandle <> 0 Then Subclass_AddResolveMessage lngAsynHandle, lngObjectPointer
ResolveHost = lngAsynHandle
End Function

'Returns the hi word from a double word.
Public Function HiWord(lngValue As Long) As Long
If (lngValue And &H80000000) = &H80000000 Then
    HiWord = ((lngValue And &H7FFF0000) \ &H10000) Or &H8000&
Else
    HiWord = (lngValue And &HFFFF0000) \ &H10000
End If
End Function

'Returns the low word from a double word.
Public Function LoWord(lngValue As Long) As Long
LoWord = (lngValue And &HFFFF&)
End Function

'Receives a string pointer and it turns it into a regular string.
Public Function StringFromPointer(ByVal lPointer As Long) As String
Dim strTemp As String
Dim lRetVal As Long

strTemp = String$(api_lstrlen(ByVal lPointer), 0)
lRetVal = api_lstrcpy(ByVal strTemp, ByVal lPointer)
If lRetVal Then StringFromPointer = strTemp
End Function

'The function takes an unsigned Integer from and API and?
'converts it to a Long for display or arithmetic purposes
Public Function UnsignedToInteger(Value As Long) As Integer
If Value < 0 Or Value >= OFFSET_2 Then Error 6 ' Overflow
If Value <= MAXINT_2 Then
    UnsignedToInteger = Value
Else
    UnsignedToInteger = Value - OFFSET_2
End If
End Function

'The function takes a Long containing a value in the range?
'of an unsigned Integer and returns an Integer that you?
'can pass to an API that requires an unsigned Integer
Public Function IntegerToUnsigned(Value As Integer) As Long
If Value < 0 Then
    IntegerToUnsigned = Value + OFFSET_2
Else
    IntegerToUnsigned = Value
End If
End Function

'Adds the socket to the m_colSocketsInst collection, and
'registers that socket with WSAAsyncSelect Winsock API
'function to receive network events for the socket.
'If this socket is the first one to be registered, the
'window and collection will be created in this function as well.
Public Function RegisterSocket(ByVal lngSocket As Long, ByVal lngObjectPointer As Long, ByVal blnEvents As Boolean) As Boolean

If m_colSocketsInst Is Nothing Then
    Set m_colSocketsInst = New Collection
    Debug.Print "OK Created socket collection"
    
    If CreateWinsockMessageWindow <> 0 Then
        Err.Raise sckOutOfMemory, "modSocketMaster.RegisterSocket", "Out of memory"
    End If
    
    Subclass_Subclass (m_lngWindowHandle)
    
End If

Subclass_AddSocketMessage lngSocket, lngObjectPointer

'Do we need to register socket events?
If blnEvents Then
    Dim lngEvents As Long
    Dim lngResult As Long
    Dim lngErrorCode As Long

    lngEvents = FD_READ Or FD_WRITE Or FD_ACCEPT Or FD_CONNECT Or FD_CLOSE
    lngResult = api_WSAAsyncSelect(lngSocket, m_lngWindowHandle, SOCKET_MESSAGE, lngEvents)
        
    If lngResult = SOCKET_ERROR Then
        Debug.Print "ERROR trying to register events from socket " & lngSocket
        lngErrorCode = Err.LastDllError
        Err.Raise lngErrorCode, "modSocketMaster.RegisterSocket", GetErrorDescription(lngErrorCode)
    Else
        Debug.Print "OK Registered events from socket " & lngSocket
    End If
End If

m_colSocketsInst.Add lngObjectPointer, "S" & lngSocket
RegisterSocket = True
End Function

'Removes the socket from the m_colSocketsInst collection
'If it is the last socket in that collection, the window
'and colection will be destroyed as well.
Public Sub UnregisterSocket(ByVal lngSocket As Long)
Subclass_DelSocketMessage lngSocket
On Error Resume Next
m_colSocketsInst.Remove "S" & lngSocket

If m_colSocketsInst.Count = 0 Then
    Set m_colSocketsInst = Nothing
    Subclass_UnSubclass
    DestroyWinsockMessageWindow
    Debug.Print "OK Destroyed socket collection"
End If
End Sub

'Returns TRUE si the socket that is passed is registered
'in the colSocketsInst collection.
Public Function IsSocketRegistered(ByVal lngSocket As Long) As Boolean
On Error GoTo Error_Handler

m_colSocketsInst.Item ("S" & lngSocket)
IsSocketRegistered = True

Exit Function

Error_Handler:
    IsSocketRegistered = False
End Function

'When ResolveHost is called an async task handle is added
'to TableA list. Use this function to remove that record.
Public Sub UnregisterResolution(ByVal lngAsynHandle As Long)
Subclass_DelResolveMessage lngAsynHandle
End Sub

'It turns a CSocketMaster instance pointer into an actual instance.
Private Function SocketObjectFromPointer(ByVal lngPointer As Long) As CSocketMaster

Dim objSocket As CSocketMaster

api_CopyMemory objSocket, lngPointer, 4&
Set SocketObjectFromPointer = objSocket
api_CopyMemory objSocket, 0&, 4&

End Function

'Assing a temporal instance of CSocketMaster to a
'socket and register this socket to the accept list.
Public Sub RegisterAccept(ByVal lngSocket As Long)
If m_colAcceptList Is Nothing Then
    Set m_colAcceptList = New Collection
    Debug.Print "OK Created accept collection"
End If
Dim Socket As CSocketMaster
Set Socket = New CSocketMaster
Socket.Accept lngSocket