modusox.bas

入侵检测是近几年发展起来的新型网络安全策略

        If m_colResolvers.Count = 0 Then
            Set m_colMemoryBlocks = Nothing
            Set m_colResolvers = Nothing
        End If
    Else
        'Pass other messages to the original window procedure
        WindowProc = CallWindowProc(m_lngPreviousValue, hwnd, uMsg, wParam, lParam)
    End If
EXIT_LABEL:
    Exit Function
ERORR_HANDLER:
    Err.Clear
    'Err.Raise Err.Number, "CSocket.WindowProc", Err.Description
End Function
Public Function RegisterSocket(ByVal lngSocketHandle As Long, ByVal lngObjectPointer As Long) As Boolean
    '********************************************************************************
    'Author    :Oleg Gdalevich
    'Date/Time :17-12-2001
    'Purpose   :Adds the socket to the m_colSockets 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.
    'Arguments :lngSocketHandle  - the socket handle
    '           lngObjectPointer - pointer to an object, instance of the CSocket class
    'Returns   :If the argument is valid and no error occurred - True.
    '********************************************************************************
    On Error GoTo ERROR_HANDLER
    Dim lngEvents                   As Long
    Dim lngRetValue                 As Long
    If p_lngWindowHandle = 0 Then
        'We have no window to catch the network events.
        'Create a new one.
        p_lngWindowHandle = CreateWinsockMessageWindow
        If p_lngWindowHandle = 0 Then
            'Cannot create a new window.
            'Set the error info to pass to the caller subroutine
            Err.Number = sckOpCanceled
            Err.Description = "The operation was canceled."
            Err.Source = "MSocketSupport.RegisterSocket"
            'Just exit to return False
            Exit Function
        End If
    End If
    'The m_colSockets collection holds information
    'about all the sockets. If the current socket is
    'the first one, create the collection object.
    If m_colSockets Is Nothing Then
        Set m_colSockets = New Collection
        'Debug.Print "The m_colSockets is created"
    End If
    'Add a new item to the m_colSockets collection.
    'The item key contains the socket handle, and the item's data
    'is the pointer to the instance of the CSocket class.
    m_colSockets.Add lngObjectPointer, "S" & lngSocketHandle
    'The lngEvents variable contains a bitmask of events we are
    'going to catch with the window callback function.
    lngEvents = FD_CONNECT Or FD_READ Or FD_WRITE Or FD_CLOSE Or FD_ACCEPT
    'Force the Winsock service to send the network event notifications
    'to the window which handle is p_lngWindowHandle.
    lngRetValue = WSAAsyncSelect(lngSocketHandle, p_lngWindowHandle, p_lngWinsockMessage, lngEvents)    'Modified:04-MAR-2002
    If lngRetValue = SOCKET_ERROR Then
        'If the WSAAsyncSelect call failed this function must
        'return False. In this case, the caller subroutine will
        'raise an error. Let's pass the error info with the Err object.
        RegisterSocket = False
        Err.Number = Err.LastDllError
        Err.Description = GetErrorDescription(Err.LastDllError)
        Err.Source = "MSocketSupport.RegisterSocket"
    Else
        RegisterSocket = True
    End If
    Exit Function
ERROR_HANDLER:
    Err.Clear
    RegisterSocket = False
End Function
Public Function UnregisterSocket(ByVal lngSocketHandle As Long) As Boolean
    '********************************************************************************
    'Author    :Oleg Gdalevich
    'Date/Time :17-12-2001
    'Purpose   :Removes the socket from the m_colSockets collection
    '           If it is the last socket in that collection, the window
    '           and colection will be destroyed as well.
    'Returns   :If the argument is valid and no error occurred - True.
    '********************************************************************************
    If (lngSocketHandle = INVALID_SOCKET) Or (m_colSockets Is Nothing) Then
        'Something wrong with the caller of this function :)
        'Return False
        Exit Function
    End If
    Call WSAAsyncSelect(lngSocketHandle, p_lngWindowHandle, 0&, 0&)
    'Remove the socket from the collection
    m_colSockets.Remove "S" & lngSocketHandle
    UnregisterSocket = True
    If m_colSockets.Count = 0 Then
        'If there are no more sockets in the collection
        'destroy the collection object and the window
        Set m_colSockets = Nothing
        UnregisterSocket = DestroyWinsockMessageWindow
    End If
End Function
Public Function ResolveHost(strHostAddress As String, ByVal lngObjectPointer As Long) As Long
    '********************************************************************************
    'Author    :Oleg Gdalevich
    'Date/Time :17-12-2001
    'Purpose   :Receives requests to resolve a host address from the CSocket class.
    'Returns   :If no errors occurred - ID of the request. Otherwise - 0.
    '********************************************************************************
    'Since this module is supposed to serve several instances of the
    'CSocket class, this function can be called to start several
    'resolving tasks that could be executed simultaneously. To
    'distinguish the resolving tasks the m_colResolvers collection
    'is used. The key of the collection's item contains a pointer to
    'the instance of the CSocket class and the item's data is the
    'Request ID, the value returned by the WSAAsyncGetHostByXXXX
    'Winsock API function. So in order to get the pointer to the
    'instance of the CSocket class by the task ID value the following
    'line of code can be used:
    '
    'lngObjPointer = CLng(m_colResolvers("R" & lngTaskID))
    '
    'The WSAAsyncGetHostByXXXX function needs the buffer (the buf argument)
    'where the data received from DNS server will be stored. We cannot use
    'a local byte array for this purpose as this buffer must be available
    'from another subroutine in this module - WindowProc, also we cannot
    'use a module level array as several tasks can be executed simultaneously
    'At least, we need a dynamic module level array of arrays - too complicated.
    'I decided to use Windows API functions for allocation some memory for
    'each resolving task: GlobalAlloc, GlobalLock, GlobalUnlock, and GlobalFree.
    '
    'To distinguish those memory blocks, the m_colMemoryBlocks collection is
    'used. The key of the collection's item contains value of the object
    'pointer, and the item's value is a handle of the allocated memory
    'block object, value returned by the GlobalAlloc function. So in order to
    'get value of the handle of the allocated memory block object by the
    'pointer to the instance of CSocket class we can use the following code:
    '
    'lngMemoryHandle = CLng(m_colMemoryBlocks("S" & lngObjPointer))
    '
    'Why do we need all this stuff?
    '
    'The problem is that the callback function give us only the resolving task
    'ID value, but we need information about:
    '   - where the data returned from the DNS server is stored
    '   - which instance of the CSocket class we need to post the info to
    '
    'So, if we know the task ID value, we can find out the object pointer:
    '   lngObjPointer = CLng(m_colResolvers("R" & lngTaskID))
    '
    'If we know the object pointer value we can find out where the data is strored:
    '   lngMemoryHandle = CLng(m_colMemoryBlocks("S" & lngObjPointer))
    '
    'That's it. :))
    Dim lngAddress                  As Long '32-bit host address
    Dim lngRequestID                As Long 'value returned by WSAAsyncGetHostByXXX
    Dim lngMemoryHandle             As Long 'handle of the allocated memory block object
    Dim lngMemoryPointer            As Long 'address of the memory block
    Dim strKey                      As String
    'Allocate some memory
    lngMemoryHandle = GlobalAlloc(GMEM_FIXED, MAXGETHOSTSTRUCT)
    If lngMemoryHandle > 0 Then
        'Lock the memory block just to get the address
        'of that memory into the lngMemoryPointer variable
        lngMemoryPointer = GlobalLock(lngMemoryHandle)
        If lngMemoryPointer = 0 Then
            'Memory allocation error
            Call GlobalFree(lngMemoryHandle)
            Exit Function
        Else
            'Unlock the memory block
            GlobalUnlock (lngMemoryHandle)
        End If
    Else
        'Memory allocation error
        Exit Function
    End If
    'If this request is the first one, create the collections
    If m_colResolvers Is Nothing Then
        Set m_colMemoryBlocks = New Collection
        Set m_colResolvers = New Collection
    End If
    strKey = "S" & CStr(lngObjectPointer)
    Call RemoveIfExists(strKey)
    'Remember the memory block location
    m_colMemoryBlocks.Add lngMemoryHandle, strKey
    'Here is a major change. Since version 1.0.6 (08-JULY-2002) the
    'SCocket class doesn't try to resolve the IP address into a
    'domain name while connecting.
    'Try to get 32-bit address
    'lngAddress = inet_addr(strHostAddress)
    lngRequestID = WSAAsyncGetHostByName(p_lngWindowHandle, m_lngResolveMessage, strHostAddress, ByVal lngMemoryPointer, MAXGETHOSTSTRUCT)
    If lngRequestID <> 0 Then
        'If the call of the WSAAsyncGetHostByXXXX is successful, the
        'lngRequestID variable contains the task ID value.
        'Remember it.
        m_colResolvers.Add lngObjectPointer, "R" & CStr(lngRequestID)
        'Return value
        ResolveHost = lngRequestID
    Else
        'If the call of the WSAAsyncGetHostByXXXX is not successful,
        'remove the item from the m_colMemoryBlocks collection.
        m_colMemoryBlocks.Remove ("S" & CStr(lngObjectPointer))
        'Free allocated memory block
        Call GlobalFree(lngMemoryHandle)
        'If there are no more resolving tasks in progress,
        'destroy the collection objects.
        If m_colResolvers.Count = 0 Then
            Set m_colResolvers = Nothing
            Set m_colMemoryBlocks = Nothing
        End If
        'Set the error info.
        Err.Number = Err.LastDllError
        Err.Description = GetErrorDescription(Err.LastDllError)
        Err.Source = "MSocketSupport.ResolveHost"
    End If
End Function
Private Function CreateWinsockMessageWindow() As Long
    '********************************************************************************
    'Author    :Oleg Gdalevich
    'Date/Time :17-12-2001
    'Purpose   :Creates a window to hook the winsock messages
    'Returns   :The window handle