VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "SimpleServer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'
' ---------------------------------------------------------------------------------
' File...........: SimpleServer.cls
' Author.........: J.A. Coutts
' Created........: 11/01/2016
' Updated........: 07/07/2017 - Added uInBuffer, uOutBuffer
' Bug fix........: 07/19/2017 - in DeleteByte routine in Modsocket
' Version........: 1.1
' Website........: http://www.yellowhead.com
' Contact........: allecnarf@hotmail.com
'
'Copyright (c) 2016 by JAC Computing
'Vernon, BC, Canada
'
'Subclassing based on CSocketMaster by Emiliano Scavuzzo
'
'SimpleServer basically performs the same functions as NewSocket. Like NewSocket,
'it supports IPv6 as well as IPv4. As long as IPv4 is used, it will operate on
'pre Windows Vista systems that do not support dual stack. This was accomplished
'by using inet_ntoa for IPv4 functions instead of inet_ntop. Unlike NewSocket,
'it cannot be used as a Control Array because of the way it handles listening
'sockets.
'
'All error messages are returned to the calling program through the Error event
'(using the CallBack function). NewSocket and it's predecessors simply reported
'errors and caried on attempting communication. This sometimes made debugging
'difficult as mutiple errors would get reported. SimpleServer attempts to exit the
'problem function on an error that would cause communication to fail.
'

'================================
'Member Socket Variables
'================================
Private m_Callback As SimpleServer
Private m_Index    As Long

'================================
'General Socket Constants
'================================
Private Const AF_UNSPEC As Long = 0
Private Const AF_INET As Long = 2
Private Const AF_INET6 As Long = 23
Private Const SOCK_STREAM As Long = 1
Private Const SOCK_DGRAM As Long = 2
Private Const INADDR_ANY As Long = 0
Private Const IPPROTO_TCP As Long = 6
Private Const IPPROTO_UDP As Long = 17
Private Const SOL_SOCKET As Long = 65535
Private Const SO_SNDBUF         As Long = &H1001&
Private Const SO_RCVBUF         As Long = &H1002&
Private Const SO_MAX_MSG_SIZE   As Long = &H2003
Private Const SO_BROADCAST      As Long = &H20
Private Const SOMAXCONN         As Long = 5
Private Const LOCAL_HOST_BUFF   As Integer = 256
Private Const FIONREAD          As Long = &H4004667F
Private Const SO_REUSEADDR As Long = &H4            'Allow local address reuse
Private Const SO_LINGER As Long = &H80              'Set TIME_WAIT
Private Const SCK_TCP As Long = 0
Private Const SCK_UDP As Long = 1
Private Const MSG_PEEK As Long = &H2

' Length of string fields for IPv4 and IPv6
Private Const INET_ADDRSTRLEN   As Long = 16
Private Const INET6_ADDRSTRLEN  As Long = 46
Private Const AI_PASSIVE        As Long = 1

'WINSOCK CONTROL ERROR CODES
Private Const sckBadState = 40006
Private Const sckInvalidArg = 40014
Private Const sckUnsupported = 40018
Private Const sckInvalidOp = 40020

'================================
'Socket states
'================================
Private Enum SockState
    sckClosed = 0
    sckOpen
    scklistening
    sckConnectionPending
    sckResolvingHost
    sckHostResolved
    sckconnecting
    sckConnected
    sckClosing
    sckError
End Enum

'================================
'MEMBER VARIABLES
'================================
Private m_hSocket           As Long    'socket handle
Private m_hListen           As Long    'listening socket handle
Private m_lMemoryPointer    As Long    'memory pointer used as buffer when resolving host
Private m_lMemoryHandle     As Long    'buffer memory handle
Private m_sRemoteHost       As String  'remote host
Private m_lRemotePort       As Long    'remote port
Private m_sRemotePort       As String  'remote port
Private m_sRemoteHostIP     As String  'remote host ip
Private m_lLocalPort        As Long    'local port
Private m_lPortListen       As Long    'listening port
Private m_sLocalIP          As String  'local IP
Private m_State             As SockState    'socket state
Private m_Protocol          As Long    'defaults to 0 = TCP (UDP = 1)
Private m_IPv               As Long    'IP Version
Private m_bAcceptClass      As Boolean 'if True then this is a Accept socket class
Private m_bEncr             As Boolean 'True for secure sockets
Private m_lSendBufferLen    As Long    'winsock buffer size for sends
Private m_lRecvBufferLen    As Long    'winsock buffer size for receives

Private Type sockaddr
    sa_family           As Integer  '2 bytes
    sa_data(25)         As Byte     '26 bytes
End Type                            'Total 28 bytes

'Basic IPv4 addressing structures.
Private Type in_addr
   s_addr   As Long
End Type
Private Type sockaddr_in
    sin_family          As Integer  '2 bytes
    sin_port            As Integer  '2 bytes
    sin_addr            As in_addr  '4 bytes
    sin_zero(0 To 7)    As Byte     '8 bytes
End Type                            'Total 16 bytes

'Basic IPv6 addressing structures.
Private Type in6_addr
    s6_addr(0 To 15)      As Byte
End Type
Private Type sockaddr_in6
    sin6_family         As Integer  '2 bytes
    sin6_port           As Integer  '2 bytes
    sin6_flowinfo       As Long     '4 bytes
    sin6_addr           As in6_addr '16 bytes
    sin6_scope_id       As Long     '4 bytes
End Type                            'Total 28 bytes

Private Type addrinfo
    ai_flags As Long
    ai_family As Long
    ai_socktype As Long
    ai_protocol As Long
    ai_addrlen As Long
    ai_canonname As Long 'strptr
    ai_addr As Long 'p sockaddr
    ai_next As Long 'p addrinfo
End Type

Private m_bSendBuffer() As Byte     'local outbound byte buffer
Private m_bRecvBuffer() As Byte     'local inbound byte buffer
Private m_bData()       As Byte     'Temporary store for recovered data
Private sa_UDPdest      As sockaddr 'UDP destination socket address

'================================
'API Functions
'================================
Private Declare Function WSACleanup Lib "ws2_32.dll" () As Long
Private Declare Function API_Socket Lib "ws2_32.dll" Alias "socket" (ByVal af As Long, ByVal stype As Long, ByVal Protocol As Long) As Long
Private Declare Function API_CloseSocket Lib "ws2_32.dll" Alias "closesocket" (ByVal s As Long) As Long
Private Declare Function API_Connect Lib "ws2_32.dll" Alias "connect" (ByVal s As Long, ByRef name As sockaddr, ByVal namelen As Long) As Long
Private Declare Function API_GetAddrInfo Lib "ws2_32.dll" Alias "getaddrinfo" (ByVal NodeName As String, ByVal ServName As String, ByVal lpHints As Long, lpResult As Long) As Long
Private Declare Function API_FreeAddrInfo Lib "ws2_32.dll" Alias "freeaddrinfo" (ByVal res As Long) As Long
Private Declare Function API_Send Lib "ws2_32.dll" Alias "send" (ByVal s As Long, ByRef buf As Byte, ByVal datalen As Long, ByVal Flags As Long) As Long
Private Declare Function API_SendTo Lib "ws2_32.dll" Alias "sendto" (ByVal s As Long, ByRef buf As Byte, ByVal datalen As Long, ByVal Flags As Long, ByRef toaddr As sockaddr, ByVal tolen As Long) As Long
Private Declare Function API_Bind Lib "ws2_32.dll" Alias "bind" (ByVal s As Long, ByRef name As sockaddr, ByRef namelen As Long) As Long
Private Declare Function API_Listen Lib "ws2_32.dll" Alias "listen" (ByVal s As Long, ByVal backlog As Long) As Long
Private Declare Function API_Accept Lib "ws2_32.dll" Alias "accept" (ByVal s As Long, ByRef addr As sockaddr, ByRef addrlen As Long) As Long
Private Declare Function API_GetSockOpt Lib "ws2_32.dll" Alias "getsockopt" (ByVal s As Long, ByVal level As Long, ByVal optname As Long, optval As Any, optlen As Long) As Long
Private Declare Function API_SetSockOpt Lib "ws2_32.dll" Alias "setsockopt" (ByVal s As Long, ByVal level As Long, ByVal optname As Long, optval As Any, ByVal optlen As Long) As Long
Private Declare Function API_GetPeerName Lib "ws2_32.dll" Alias "getpeername" (ByVal s As Long, ByRef name As sockaddr, ByRef namelen As Long) As Long
Private Declare Function API_GetSockName Lib "ws2_32.dll" Alias "getsockname" (ByVal s As Long, ByRef name As sockaddr, ByRef namelen As Long) As Long
Private Declare Function API_GetHostName Lib "ws2_32.dll" Alias "gethostname" (ByVal host_name As String, ByVal namelen As Long) As Long
Private Declare Function API_IoctlSocket Lib "ws2_32.dll" Alias "ioctlsocket" (ByVal s As Long, ByVal cmd As Long, ByRef argp As Long) As Long
Private Declare Function API_Recv Lib "ws2_32.dll" Alias "recv" (ByVal s As Long, ByRef buf As Byte, ByVal datalen As Long, ByVal Flags As Long) As Long
Private Declare Function API_RecvFrom Lib "ws2_32.dll" Alias "recvfrom" (ByVal s As Long, ByRef buf As Byte, ByVal datalen As Long, ByVal Flags As Long, ByRef fromaddr As sockaddr, ByRef fromlen As Long) As Long

Private Declare Function inet_ntop Lib "ws2_32.dll" (ByVal af As Long, ByRef ppAddr As Any, ByRef pStringBuf As Any, ByVal StringBufSize As Long) As Long
Private Declare Function inet_ntoa Lib "ws2_32.dll" (ByVal iaddr As Long) As Long
Private Declare Function ntohs Lib "ws2_32.dll" (ByVal netshort As Long) As Integer

'================================
'Generalized functions
'================================
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Friend Property Get BufferSize() As Long
    BufferSize = m_lSendBufferLen
End Property

Public Sub WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
    '  ****  WARNING WARNING WARNING WARNING ******
    'This sub MUST be the first on the class. DO NOT attempt
    'to change it's location or the code will CRASH.
    'This sub receives system messages from our WndProc.
    Dim LoWord As Long
    Dim HiWord As Long
    Select Case uMsg
    Case SOCKET_MESSAGE
        LoWord = lParam And &HFFFF&
        If (lParam And &H80000000) = &H80000000 Then
            HiWord = ((lParam And &H7FFF0000) \ &H10000) Or &H8000&
        Else
            HiWord = (lParam And &HFFFF0000) \ &H10000
        End If
        PostSocket LoWord, HiWord
    End Select
End Sub


Friend Function Accept(requestID As Long, lRemotePort As Long, sRemoteHostIP As String) As Boolean
    Const Routine As String = "SimpleServer.Accept"
    'Socket should be either Closed or in Error
    If m_State <> sckClosed Then
        Call m_Callback.Error(0, sckInvalidOp, "Socket is not Available", Routine)
    End If
    'If the calling program indicates that the connection wasn't accepted by
    'setting lRemotePort to zero, we must close the socket that was created.
    If lRemotePort = 0 Then
        API_CloseSocket requestID
        Call PrintDebug("OK Closed accepted socket: " & CStr(requestID))
        Exit Function
    End If
    m_hSocket = requestID 'Use the handle created by FD_ACCEPT message
    m_sRemoteHostIP = sRemoteHostIP
    m_lRemotePort = lRemotePort
    m_Protocol = SCK_TCP
    Call ProcessOptions
    If IsSocketRegistered(requestID) Then
        Call m_Callback.Error(0, sckBadState, "Wrong protocol or connection state for the requested transaction or request", Routine)
        Exit Function
    Else
        m_State = sckConnected
        Call PrintDebug("STATE: sckConnected")
        Call modSocket.RegisterSocket(m_hSocket, ObjPtr(Me), False)
    End If
    Accept = True
End Function


Friend Property Get bInBuffer() As Byte()
    bInBuffer = m_bData
End Property

Friend Property Let bOutBuffer(bNewValue() As Byte)
    Call AddByte(m_bSendBuffer, bNewValue)
End Property

Friend Function BuildArray(ByVal lSize As Long, ByVal blnPeek As Boolean, ByRef lErrorCode As Long) As Byte()
    Dim lRet        As Long
    Dim tmpSa       As sockaddr
    Dim lFlags      As Long
    Dim bTmp() As Byte
    If m_Protocol = SCK_TCP Then 'TCP transfers data from m_bRecvBuffer
        ReDim bTmp(lSize - 1)
        CopyMemory bTmp(0), m_bRecvBuffer(0), lSize
        BuildArray = bTmp
        If Not blnPeek Then
            Call DeleteByte(m_bRecvBuffer, lSize)
        End If
    Else 'UDP recovers data from Winsock buffer
        If blnPeek Then lFlags = MSG_PEEK
        ReDim bTmp(lSize - 1)
        lRet = API_RecvFrom(m_hSocket, bTmp(0), lSize, lFlags, tmpSa, LenB(tmpSa))
        If lRet = SOCKET_ERROR Then
            lErrorCode = Err.LastDllError
        End If
        BuildArray = bTmp
        GetRemoteInfoFromSI tmpSa, m_lRemotePort, m_sRemoteHostIP, m_sRemoteHost
    End If
End Function

Friend Property Get BytesReceived() As Long
    If m_Protocol = SCK_TCP Then
        BytesReceived = GetbSize(m_bRecvBuffer)
    Else
        BytesReceived = GetBufferLenUDP
    End If
End Property

Friend Function CloseSocket() As Boolean
    Const Routine As String = "SimpleServer.CloseSocket"
    Dim lErrorCode As Long
    Dim lRet As Long
    Dim bTmp() As Byte
    If Not m_hSocket = SOCKET_ERROR Then
        lRet = API_CloseSocket(m_hSocket)
        If lRet = -1 Then
            m_State = sckError
            lErrorCode = Err.LastDllError
            Call m_Callback.Error(m_Index, lErrorCode, "Could not Close Socket!", Routine)
        Else
            Call modSocket.UnregisterSocket(m_hSocket)
            m_hSocket = SOCKET_ERROR
            m_State = sckClosed
            Call PrintDebug("STATE: sckClosed")
            m_sLocalIP = vbNullString
            m_sRemoteHostIP = ""
            m_bRecvBuffer = bTmp
            m_bSendBuffer = bTmp
            m_lSendBufferLen = 0
            m_lRecvBufferLen = 0
            CloseSocket = True
        End If
    End If
End Function



Private Sub EmptyBuffer()
    'Empty winsock incoming buffer from a UDP socket.
    Dim B As Byte
    API_Recv m_hSocket, B, Len(B), 0&
End Sub

Friend Property Get Callback(Optional ByVal Index As Long) As SimpleServer
'The Friend scope modifier prevents the following properties and methods from
'being Implemented yet still allows them to be accessible within the project
    Set Callback = m_Callback
End Property

Friend Property Set Callback(ByVal Index As Long, ByRef RHS As SimpleServer)
    m_Index = Index
    Set m_Callback = RHS
End Property

Public Sub CloseSck(ByVal Index As Long)

End Sub

Public Sub Connect(ByVal Index As Long)

End Sub

Public Sub ConnectionRequest(ByVal Index As Long, ByVal requestID As Long, ByVal lRemotePort As Long, ByVal sRemoteHostIP As String)

End Sub

Public Sub DataArrival(ByVal Index As Long, ByVal bytesTotal As Long)

End Sub

Public Sub EncrDataArrival(ByVal Index As Long, ByVal bytesTotal As Long)

End Sub

Friend Property Let EncrFlg(ByVal NewValue As Boolean)
    m_bEncr = NewValue
End Property


Public Sub Error(ByVal Index As Long, ByVal Number As Long, Description As String, ByVal Source As String)

End Sub

Public Sub SendComplete(ByVal Index As Long)

End Sub

Public Sub SendProgress(ByVal Index As Long, ByVal bytesSent As Long, ByVal bytesRemaining As Long)

End Sub

Private Function GetBufferLenUDP() As Long
    'Returns winsock incoming buffer length from a UDP socket.
    Dim lRet    As Long
    Dim lBuff   As Long
    lRet = API_IoctlSocket(m_hSocket, FIONREAD, lBuff)
    If lRet = SOCKET_ERROR Then
        GetBufferLenUDP = 0
    Else
        GetBufferLenUDP = lBuff
    End If
End Function

Private Function GetLocalHostName() As String
    Const Routine As String = "SimpleServer.GetLocalHostName"
    Dim HostNameBuf As String * LOCAL_HOST_BUFF
    Dim lRet As Long
    Dim lErrorCode As Long
    lRet = API_GetHostName(HostNameBuf, LOCAL_HOST_BUFF)
    If lRet = SOCKET_ERROR Then
        GetLocalHostName = vbNullString
        lErrorCode = Err.LastDllError
        Call m_Callback.Error(m_Index, lErrorCode, GetErrorDescription(lErrorCode), Routine)
    Else
        GetLocalHostName = Left(HostNameBuf, InStr(1, HostNameBuf, Chr(0)) - 1)
    End If
End Function

Private Function GetLocalPort(ByVal hSocket As Long) As Long
    'Returns local port from a connected or bound socket.
    'Returns SOCKET_ERROR if fails.
    Dim newSa As sockaddr
    Dim Sin4 As sockaddr_in
    Dim Sin6 As sockaddr_in6
    Dim lRet As Long
    lRet = API_GetSockName(hSocket, newSa, LenB(newSa))
    If lRet = SOCKET_ERROR Then
        GetLocalPort = SOCKET_ERROR
    Else
        If newSa.sa_family = AF_INET6 Then
            CopyMemory Sin6, newSa, LenB(Sin6)  'Save to sockaddr_in6
            GetLocalPort = modSocket.IntegerToUnsigned(ntohs(Sin6.sin6_port))
        Else
            CopyMemory Sin4, newSa, LenB(Sin4)  'Save to sockaddr_in
            GetLocalPort = modSocket.IntegerToUnsigned(ntohs(Sin4.sin_port))
        End If
    End If
End Function

Private Function GetRemoteInfo(ByVal hSocket As Long, ByRef lRemotePort As Long, ByRef strRemoteHostIP As String, ByRef strRemoteHost As String) As Boolean
    'Retrieves remote info from a connected socket.
    'If succeeds returns TRUE and loads the arguments.
    'If fails returns FALSE and arguments are not loaded.
    Dim lRet As Long
    Dim tmpSa As sockaddr
    GetRemoteInfo = False
    lRet = API_GetPeerName(hSocket, tmpSa, LenB(tmpSa))
    If lRet = 0 Then
        GetRemoteInfo = True
        GetRemoteInfoFromSI tmpSa, m_lRemotePort, m_sRemoteHostIP, m_sRemoteHost
    Else
       lRemotePort = 0
       strRemoteHostIP = ""
       strRemoteHost = ""
    End If
End Function

Private Sub GetRemoteInfoFromSI(ByRef newSa As sockaddr, ByRef lRemotePort As Long, ByRef sRemoteHostIP As String, ByRef sRemoteHost As String)
    'Gets remote info from a sockaddr_in structure.
    Dim lRet As Long
    Dim Sin4 As sockaddr_in
    Dim Sin6 As sockaddr_in6
    Dim aLen As Long
    Dim bBuffer() As Byte
    If newSa.sa_family = AF_INET6 Then
        aLen = INET6_ADDRSTRLEN
        CopyMemory Sin6, newSa, LenB(Sin6)  'Save to sockaddr_in6
        lRemotePort = IntegerToUnsigned(ntohs(Sin6.sin6_port))
        ReDim bBuffer(0 To aLen - 1)    'Resize string buffer
        'Get IPv6 address as string
        lRet = inet_ntop(AF_INET6, Sin6.sin6_addr, bBuffer(0), aLen)
    Else 'Must be IPv4
        aLen = INET_ADDRSTRLEN
        CopyMemory Sin4, newSa, LenB(Sin4)  'Save to sockaddr_in
        lRemotePort = IntegerToUnsigned(ntohs(Sin4.sin_port))
        ReDim bBuffer(0 To aLen - 1)  'Resize string buffer
        'Get IPv4 address as string
        lRet = inet_ntoa(Sin4.sin_addr.s_addr)
    End If
    If lRet Then sRemoteHostIP = StringFromPointer(lRet)
    m_sRemoteHost = ""
End Sub

Private Function Initialize() As Boolean
    'socket's handle default value
    m_hSocket = SOCKET_ERROR
    'Set IPv Flag default value
    IPvFlg = 4 'Defaults to IPv4
    Initialize = modSocket.Initialize
End Function

Friend Property Get IPvFlg() As Long
    IPvFlg = m_IPv
End Property

Friend Property Let IPvFlg(ByVal IPvFlg As Long)
    m_IPv = IPvFlg
End Property

Friend Function Listen(LocalPort As Long) As Boolean
    Const Routine As String = "SimpleServer.Listen"
    Dim sa_local As sockaddr
    Dim lRet As Long
    Dim lErrorCode As Long
    Dim IPFamily As Long
    If m_IPv = 4 Then
        IPFamily = AF_INET
    Else
        IPFamily = AF_INET6
    End If
    'Create TCP socket
    m_Protocol = SCK_TCP
    m_State = sckconnecting
    m_hSocket = API_Socket(IPFamily, SOCK_STREAM, IPPROTO_TCP)
    If m_hSocket = SOCKET_ERROR Then
        m_State = sckError
        Call m_Callback.Error(0, m_hSocket, GetErrorDescription(m_hSocket), Routine)
        Exit Function
    Else
        ProcessOptions 'Get Send/Recv buffer lengths & register socket
        If Not modSocket.RegisterSocket(m_hSocket, ObjPtr(Me), True) Then Exit Function
    End If
    'Populate the local sockaddr
    sa_local.sa_family = IPFamily
    sa_local.sa_data(0) = PeekB(VarPtr(LocalPort) + 1)
    sa_local.sa_data(1) = PeekB(VarPtr(LocalPort))
    'Bind to socket
    lRet = API_Bind(m_hSocket, sa_local, LenB(sa_local))
    If lRet = SOCKET_ERROR Then
        m_State = sckError
        Call m_Callback.Error(0, lRet, GetErrorDescription(lRet), Routine)
        Exit Function
    Else 'Set into listening mode
        m_State = sckOpen
        lRet = API_Listen(m_hSocket, SOMAXCONN)
        If lRet = SOCKET_ERROR Then
            lErrorCode = Err.LastDllError
            Call m_Callback.Error(0, lErrorCode, GetErrorDescription(lErrorCode), Routine)
        Else
            m_State = scklistening
            m_lPortListen = LocalPort
            Listen = True
            Call PrintDebug("STATE: sckListening")
        End If
    End If
End Function

Friend Property Get LocalHostName() As String
    LocalHostName = GetLocalHostName
End Property

Friend Property Get LocalPort() As Long
    LocalPort = GetLocalPort(m_hSocket)
End Property

Friend Sub PeekData(ByRef data() As Byte, Optional maxLen As Long)
    Const Routine As String = "SimpleServer.PeekData"
    Dim lBytesRecv  As Long
    If m_Protocol = SCK_TCP Then
        If m_State <> sckConnected Then
            Call m_Callback.Error(m_Index, sckBadState, "Wrong protocol or connection state for the requested transaction or request", Routine)
            Exit Sub
        End If
    Else
        If m_State <> sckOpen Then
            Call m_Callback.Error(m_Index, sckBadState, "Wrong protocol or connection state for the requested transaction or request", Routine)
            Exit Sub
        End If
        If GetBufferLenUDP = 0 Then Exit Sub
    End If
    If maxLen < 1 Then
        If m_Protocol = SCK_TCP Then
            maxLen = GetbSize(m_bRecvBuffer)
        Else
            maxLen = GetBufferLenUDP
        End If
    End If
    lBytesRecv = RecvData(data, True, maxLen)
    Call PrintDebug("OK Bytes obtained from buffer: " & CStr(lBytesRecv))
End Sub

Private Sub PostSocket(ByVal lEventID As Long, ByVal lErrorCode As Long)
    'This procedure is called by the WindowProc callback function
    'from the modSocket module. The lEventID argument is an ID of the
    'network event that occurred for the socket. The lErrorCode
    'argument contains an error code only if an error was occurred
    'during an asynchronous execution.
    Const Routine As String = "SimpleServer.PostSocket"
    Dim newSa As sockaddr
    Dim Sin4 As sockaddr_in
    Dim Sin6 As sockaddr_in6
    Dim lRet As Long
    Dim lBytesRecvd As Long
    If lErrorCode <> 0 Then
        m_State = sckError
        Call PrintDebug("STATE: sckError")
        Call m_Callback.Error(m_Index, lErrorCode, GetErrorDescription(lErrorCode), "Windows Message")
        CloseSocket
        Exit Sub
    End If
    Select Case lEventID
    '======================================================================
    Case FD_CONNECT
        'Arrival of this message means that the connection initiated by the call
        'of the connect Winsock API function was successfully established.
        Call PrintDebug("FD_CONNECT " & CStr(m_hSocket))
        If m_State <> sckconnecting Then
            Call PrintDebug("WARNING: Omitting FD_CONNECT")
            Exit Sub
        End If
        'Get the connection local end-point parameters
        lRet = API_GetPeerName(m_hSocket, newSa, LenB(newSa))
        If lRet = 0 Then
            If newSa.sa_family = AF_INET6 Then
                ReDim bBuffer(0 To INET6_ADDRSTRLEN - 1)    'Resize string buffer
                CopyMemory Sin6, newSa, LenB(Sin6)  'Save to sockaddr_in6
                m_lRemotePort = modSocket.IntegerToUnsigned(ntohs(Sin6.sin6_port))
                lRet = inet_ntop(AF_INET6, Sin6.sin6_addr, bBuffer(0), INET6_ADDRSTRLEN)
            Else
                ReDim bBuffer(0 To INET_ADDRSTRLEN - 1)    'Resize string buffer
                CopyMemory Sin4, newSa, LenB(Sin4)  'Save to sockaddr_in
                m_lRemotePort = modSocket.IntegerToUnsigned(ntohs(Sin4.sin_port))
                lRet = inet_ntoa(Sin4.sin_addr.s_addr)
            End If
            If lRet Then m_sRemoteHostIP = StringFromPointer(lRet)
        End If
        m_State = sckConnected
        Call PrintDebug("STATE: sckConnected")
        Call m_Callback.Connect(0)
    '======================================================================
    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.
        Call PrintDebug("FD_WRITE " & CStr(m_hSocket))
        If m_State <> sckConnected Then
            Call PrintDebug("WARNING: Omitting FD_WRITE")
            Exit Sub
        End If
        If GetbSize(m_bSendBuffer) > 0 Then
            If m_Protocol = SCK_TCP Then
                TCPSend
            Else
                UDPSend
            End If
        End If
    '======================================================================
    Case FD_READ
        'Some data has arrived for this socket.
        Call PrintDebug("FD_READ " & CStr(m_hSocket))
        If m_Protocol = SCK_TCP Then
            If m_State <> sckConnected Then
                Call PrintDebug("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.
            lBytesRecvd = RecvDataToBuffer
            If lBytesRecvd > 0 Then
                If m_bEncr Then
                    Call m_Callback.EncrDataArrival(m_Index, GetbSize(m_bRecvBuffer))
                Else
                    Call m_Callback.DataArrival(m_Index, GetbSize(m_bRecvBuffer))
                End If
            End If
        Else 'UDP protocol
            If m_State <> sckOpen Then
                Call PrintDebug("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.
            lBytesRecvd = GetBufferLenUDP
            If lBytesRecvd > 0 Then
                If m_bEncr Then
                    Call m_Callback.EncrDataArrival(m_Index, lBytesRecvd)
                Else
                    Call m_Callback.DataArrival(m_Index, lBytesRecvd)
                End If
            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 PrintDebug("FD_ACCEPT " & CStr(m_hSocket))
        If m_State <> scklistening Then
            Call PrintDebug("WARNING: Omitting FD_ACCEPT")
            Exit Sub
        End If
        'Create a new socket for the requested connection.
        lRet = API_Accept(m_hSocket, newSa, LenB(newSa))
        If lRet = SOCKET_ERROR Then
            lErrorCode = Err.LastDllError
            Call m_Callback.Error(m_Index, lErrorCode, GetErrorDescription(lErrorCode), Routine)
        Else
            Call GetRemoteInfo(lRet, m_lRemotePort, m_sRemoteHostIP, m_sRemoteHost)
            Call PrintDebug("OK Accept socket? " & CStr(lRet))
            Call m_Callback.ConnectionRequest(0, lRet, m_lRemotePort, m_sRemoteHostIP)
        End If
    '======================================================================
    Case FD_CLOSE
        'This message means that the remote host is closing the conection
        Call PrintDebug("FD_CLOSE " & CStr(m_hSocket))
        If m_State <> sckConnected Then
            Call PrintDebug("WARNING: Omitting FD_CLOSE")
            Exit Sub
        End If
        m_State = sckClosing
        Call PrintDebug("REMOTE: sckClosing")
        Call m_Callback.CloseSck(m_Index)
    End Select
End Sub

Private Sub ProcessOptions()
    'Retrieves some socket options.
    'If it is an UDP socket also sets SO_BROADCAST option.
    Const Routine As String = "SimpleServer.ProcessOptions"
    Dim lRet As Long
    Dim lBuffer As Long
    Dim lErrorCode As Long
    If m_Protocol = SCK_TCP Then
        lRet = API_GetSockOpt(m_hSocket, SOL_SOCKET, SO_RCVBUF, lBuffer, LenB(lBuffer))
        If lRet = SOCKET_ERROR Then
            lErrorCode = Err.LastDllError
            Call m_Callback.Error(m_Index, lErrorCode, GetErrorDescription(lErrorCode), Routine)
        Else
            m_lRecvBufferLen = lBuffer
        End If
        lRet = API_GetSockOpt(m_hSocket, SOL_SOCKET, SO_SNDBUF, lBuffer, LenB(lBuffer))
        If lRet = SOCKET_ERROR Then
            lErrorCode = Err.LastDllError
            Call m_Callback.Error(m_Index, lErrorCode, GetErrorDescription(lErrorCode), Routine)
        Else
            m_lSendBufferLen = lBuffer
        End If
    Else
        lBuffer = 1
        lRet = API_SetSockOpt(m_hSocket, SOL_SOCKET, SO_BROADCAST, lBuffer, LenB(lBuffer))
        lRet = API_GetSockOpt(m_hSocket, SOL_SOCKET, SO_MAX_MSG_SIZE, lBuffer, LenB(lBuffer))
        If lRet = SOCKET_ERROR Then
            lErrorCode = Err.LastDllError
            Call m_Callback.Error(m_Index, lErrorCode, GetErrorDescription(lErrorCode), Routine)
        Else
            m_lRecvBufferLen = lBuffer
            m_lSendBufferLen = lBuffer
        End If
    End If
    Call PrintDebug("Winsock buffer size for sends: " & CStr(m_lRecvBufferLen))
    Call PrintDebug("Winsock buffer size for receives: " & CStr(m_lSendBufferLen))
End Sub

Friend Property Get Protocol() As Long
    Protocol = m_Protocol
End Property

Friend Sub RecoverData(Optional maxLen As Long)
    Const Routine As String = "SimpleServer.RecoverData"
    Dim lBytesRecv  As Long
    If m_Protocol = SCK_TCP Then
        If m_State <> sckConnected And Not m_bAcceptClass Then
            Call m_Callback.Error(m_Index, sckBadState, "Wrong protocol or connection state for the requested transaction or request", Routine)
            Exit Sub
        End If
    Else
        If m_State <> sckOpen Then
            Call m_Callback.Error(m_Index, sckBadState, "Wrong protocol or connection state for the requested transaction or request", Routine)
            Exit Sub
        End If
        If GetBufferLenUDP = 0 Then Exit Sub
    End If
    If maxLen < 1 Then 'MaxLen not provided
        If m_Protocol = SCK_TCP Then
            maxLen = GetbSize(m_bRecvBuffer)
        Else
            maxLen = GetBufferLenUDP
        End If
    End If
    lBytesRecv = RecvData(m_bData, False, maxLen)
    Call PrintDebug("OK Bytes obtained from buffer: " & CStr(lBytesRecv))
 End Sub

Private Function RecvData(ByRef bData() As Byte, ByVal blnPeek As Boolean, Optional maxLen As Long) As Long
    Const Routine As String = "SimpleServer.RecvData"
    'Using TCP, the data is retrieved from a local buffer (m_bRecvBuffer).
    'Using UDP, the data is retrieved from the winsock buffer.
    'If blnPeek is TRUE, the function returns number of bytes in the
    'buffer, and copies the buffer data into the data argument.
    'If blnPeek is FALSE, then this function returns number of bytes in the
    'buffer and moves the buffer data into the data argument.
    Dim lBuffLen        As Long
    Dim lErrorCode      As Long
    Dim bTmp()          As Byte
    If m_Protocol = SCK_TCP Then
        lBuffLen = GetbSize(m_bRecvBuffer)
    Else
        lBuffLen = GetBufferLenUDP
    End If
    If maxLen = 0 Then 'if maxLen argument is missing
        RecvData = lBuffLen
        If RecvData = 0 Then
            bData = bTmp
            Exit Function
        Else
            bData = BuildArray(lBuffLen, blnPeek, lErrorCode)
        End If
    Else 'if maxLen argument is not missing
        If lBuffLen = 0 Then
            RecvData = 0
            bData = bTmp
            If m_Protocol = SCK_UDP Then
                EmptyBuffer
                Call m_Callback.Error(m_Index, WSAEMSGSIZE, GetErrorDescription(WSAEMSGSIZE), Routine)
            End If
            Exit Function
        ElseIf maxLen > lBuffLen Then
            RecvData = lBuffLen
            bData = BuildArray(lBuffLen, blnPeek, lErrorCode)
        Else
            RecvData = maxLen
            bData = BuildArray(maxLen, blnPeek, lErrorCode)
        End If
    End If
    'if BuildArray returns an error is handled here
    If lErrorCode <> 0 Then
        Call m_Callback.Error(m_Index, lErrorCode, GetErrorDescription(lErrorCode), Routine)
    End If
End Function

Private Function RecvDataToBuffer() As Long
    'This function retrieves data from the Winsock buffer
    'into the class local buffer. The function returns number
    'of bytes retrieved (received).
    Const Routine As String = "SimpleServer.RecvDataToBuffer"
    Dim bInArray()     As Byte
    Dim lBytesRecv      As Long
    Dim lErrorCode      As Long
    ReDim bInArray(m_lRecvBufferLen - 1)
    lBytesRecv = API_Recv(m_hSocket, bInArray(0), m_lRecvBufferLen, 0&)
    If lBytesRecv = SOCKET_ERROR Then
        m_State = sckError
        Call PrintDebug("STATE: sckError")
        lErrorCode = Err.LastDllError
        Call m_Callback.Error(m_Index, lErrorCode, GetErrorDescription(lErrorCode), Routine)
    ElseIf lBytesRecv > 0 Then
        Call AddByte(m_bRecvBuffer, bInArray, lBytesRecv)
        RecvDataToBuffer = lBytesRecv
    End If
End Function

Friend Property Get RemoteHostIP() As String
    RemoteHostIP = m_sRemoteHostIP
End Property

Friend Sub TCPSend()
    Const Routine As String = "SimpleServer.TCPSend"
    Dim bData()         As Byte
    Dim lBufLen         As Long
    Dim lSendLen        As Long
    Dim lRet            As Long
    Dim lTotalSent      As Long
    Dim lErrorCode      As Long
    Dim lTemp           As Long
    Dim bTmp() As Byte
    If m_State <> sckConnected Then
        Call m_Callback.Error(m_Index, sckBadState, "Wrong connection state for TCP Send!", Routine)
        Exit Sub
    End If
    lBufLen = GetbSize(m_bSendBuffer)
    Do Until lRet = SOCKET_ERROR Or lBufLen = 0
        If GetbSize(m_bSendBuffer) = 0 Then
            Exit Sub
        ElseIf lBufLen > m_lSendBufferLen Then
            lSendLen = m_lSendBufferLen
            ReDim bData(lSendLen - 1)
            CopyMemory bData(0), m_bSendBuffer(0), lSendLen
        Else
            lSendLen = lBufLen
            bData = m_bSendBuffer
        End If
        lRet = API_Send(m_hSocket, bData(0), lSendLen, 0&)
        If lRet = SOCKET_ERROR Then
            lErrorCode = Err.LastDllError
            If lErrorCode = WSAEWOULDBLOCK Then
                Call PrintDebug("WARNING: Send buffer full, waiting...")
                If lTotalSent > 0 Then Call m_Callback.SendProgress(m_Index, lTotalSent, lBufLen)
            Else
                m_State = sckError
                Call PrintDebug("STATE: sckError")
                Call m_Callback.Error(m_Index, lErrorCode, GetErrorDescription(lErrorCode), Routine)
            End If
        Else
            Call PrintDebug("OK Bytes sent: " & CStr(lRet))
            lTotalSent = lTotalSent + lRet
            If lBufLen > lRet Then
                Call DeleteByte(m_bSendBuffer, lRet)
            Else
                Call PrintDebug("OK Finished SENDING")
                m_bSendBuffer = bTmp
                lTemp = lTotalSent
                lTotalSent = 0
                Call m_Callback.SendProgress(m_Index, lTemp, 0)
                Call m_Callback.SendComplete(m_Index)
            End If
        End If
        lBufLen = GetbSize(m_bSendBuffer)
    Loop
End Sub

Friend Sub UDPSend()
    Const Routine As String = "SimpleServer.UDPSend"
    Dim bData()     As Byte
    Dim lBufLen     As Long
    Dim lRet        As Long
    Dim lErrorCode  As Long
    Dim lTotalSent  As Long
    Dim lTemp       As Long
    Dim bTmp()      As Byte
    If m_State <> sckOpen Then
        Call m_Callback.Error(m_Index, sckBadState, "Wrong socket state for UDP Send!", Routine)
        Exit Sub
    End If
    lBufLen = GetbSize(m_bSendBuffer)
    bData = m_bSendBuffer
    m_bSendBuffer = bTmp
    lRet = API_SendTo(m_hSocket, bData(0), lBufLen, 0&, sa_UDPdest, LenB(sa_UDPdest))
    If lRet = SOCKET_ERROR Then
        lErrorCode = Err.LastDllError
        m_State = sckError
        Call PrintDebug("STATE: sckError")
        Call m_Callback.Error(m_Index, lErrorCode, GetErrorDescription(lErrorCode), Routine)
    Else
        Call PrintDebug("OK Bytes sent: " & CStr(lRet))
        lTotalSent = lTotalSent + lRet
        If lBufLen > lRet Then
            Call DeleteByte(m_bSendBuffer, lRet)
        Else
            Call PrintDebug("OK Finished SENDING")
            m_bSendBuffer = bTmp
            lTemp = lTotalSent
            lTotalSent = 0
            Call m_Callback.SendProgress(m_Index, lTemp, 0)
            Call m_Callback.SendComplete(m_Index)
        End If
    End If
End Sub

Friend Property Get uInBuffer() As String
    uInBuffer = ByteToUni(m_bData)
End Property

Friend Property Let uOutBuffer(sNewValue As String)
    Dim bTmp() As Byte
    bTmp = sNewValue
    Call AddByte(m_bSendBuffer, bTmp)
End Property


Friend Property Get sInBuffer() As String
    sInBuffer = ByteToStr(m_bData)
End Property

Friend Property Let sOutBuffer(sNewValue As String)
    Dim bTmp() As Byte
    bTmp = StrToByte(sNewValue)
    Call AddByte(m_bSendBuffer, bTmp)
End Property

Friend Property Get State() As Long
    State = m_State
End Property

Friend Function TCPConnect(RemoteHost As String, RemotePort As Long, Optional LocalPort As Long) As Boolean
    Const Routine As String = "SimpleServer.TCPConnect"
    Dim lErrorCode As Long
    Dim sa_local As sockaddr
    Dim sa_dest As sockaddr
    Dim lRet As Long
    Dim ptrResult As Long
    Dim Hints As addrinfo
    Dim IPFamily As Long
    If m_IPv = 4 Then
        IPFamily = AF_INET
    Else
        IPFamily = AF_INET6
    End If
    'Create TCP socket
    m_Protocol = SCK_TCP
    m_State = sckconnecting
    m_hSocket = API_Socket(IPFamily, SOCK_STREAM, IPPROTO_TCP)
    If m_hSocket = SOCKET_ERROR Then
        m_State = sckError
        Call m_Callback.Error(m_Index, m_hSocket, GetErrorDescription(m_hSocket), Routine)
        Exit Function
    Else
        'Get Send/Recv buffer lengths & register socket
        ProcessOptions
        If Not modSocket.RegisterSocket(m_hSocket, ObjPtr(Me), True) Then Exit Function
    End If
    'Recover info about the destination.
    Hints.ai_family = IPFamily
    lRet = API_GetAddrInfo(RemoteHost, RemotePort, VarPtr(Hints), ptrResult)
    If lRet <> 0 Then
        m_State = sckError
        Call m_Callback.Error(m_Index, lRet, GetErrorDescription(lRet), Routine)
        Exit Function
    End If
    Hints.ai_next = ptrResult   'Point to first structure in linked list
    CopyMemory Hints, ByVal Hints.ai_next, LenB(Hints) 'Copy next address info to Hints
    CopyMemory sa_dest, ByVal Hints.ai_addr, LenB(sa_dest) 'Save sockaddr portion
    API_FreeAddrInfo (ptrResult) ' free the linked list
    If LocalPort > 0 Then
        'Populate the local sockaddr
        sa_local.sa_family = IPFamily
        sa_local.sa_data(0) = PeekB(VarPtr(LocalPort) + 1)
        sa_local.sa_data(1) = PeekB(VarPtr(LocalPort))
        lRet = API_SetSockOpt(m_hSocket, SOL_SOCKET, SO_LINGER, 1&, 4&)
        If lRet = SOCKET_ERROR Then
            m_State = sckError
            Call m_Callback.Error(m_Index, lRet, GetErrorDescription(lRet), Routine)
            Exit Function
        End If
        lRet = API_SetSockOpt(m_hSocket, SOL_SOCKET, SO_REUSEADDR, 1&, 4&)
        If lRet = SOCKET_ERROR Then
            m_State = sckError
            Call m_Callback.Error(m_Index, lRet, GetErrorDescription(lRet), Routine)
            Exit Function
        End If
        lRet = API_Bind(m_hSocket, sa_local, LenB(sa_local))
        If lRet = SOCKET_ERROR Then
            m_State = sckError
            Call m_Callback.Error(m_Index, lRet, GetErrorDescription(lRet), Routine)
            Exit Function
        End If
    End If
    'Connect to sockaddr
    m_State = sckconnecting
    lRet = API_Connect(m_hSocket, sa_dest, LenB(sa_dest))
    'Check and handle errors
    If lRet = SOCKET_ERROR Then
        lErrorCode = Err.LastDllError
        If lErrorCode <> WSAEWOULDBLOCK Then
            m_State = sckError
            Call m_Callback.Error(m_Index, lErrorCode, GetErrorDescription(lErrorCode), Routine)
            Exit Function
        End If
    End If
    TCPConnect = True
End Function

Friend Function UDPInit(RemoteHost As String, RemotePort As Long, LocalPort As Long) As Boolean
    Const Routine As String = "SimpleServer.UDPInit"
    'Using UDP, we just bind the socket to a known port
    Dim lErrorCode As Long
    Dim sa_local As sockaddr
    Dim lRet As Long
    Dim ptrResult As Long
    Dim Hints As addrinfo
    Dim IPFamily As Long
    Dim SocketExists As Boolean
    If m_hSocket > 1 Then SocketExists = True
    If m_IPv = 4 Then
        IPFamily = AF_INET
    Else
        IPFamily = AF_INET6
    End If
    m_Protocol = SCK_UDP
    'If UDP socket does not exist, create and register it
    Debug.Print "UDP Socket " & CStr(m_hSocket)
    If Not SocketExists Then
        m_hSocket = API_Socket(IPFamily, SOCK_DGRAM, IPPROTO_UDP)
        If m_hSocket = SOCKET_ERROR Then
            m_State = sckError
            Call m_Callback.Error(m_Index, m_hSocket, GetErrorDescription(m_hSocket), Routine)
            Exit Function
        Else
            'Get Send/Recv buffer lengths & register socket
            ProcessOptions
            If Not modSocket.RegisterSocket(m_hSocket, ObjPtr(Me), True) Then Exit Function
        End If
    End If
    'Recover info about the destination.
    Hints.ai_family = IPFamily
    lRet = API_GetAddrInfo(RemoteHost, RemotePort, VarPtr(Hints), ptrResult)
    If lRet <> 0 Then
        m_State = sckError
        Call m_Callback.Error(m_Index, lRet, GetErrorDescription(lRet), Routine)
        Exit Function
    End If
    Hints.ai_next = ptrResult   'Point to first structure in linked list
    CopyMemory Hints, ByVal Hints.ai_next, LenB(Hints) 'Copy next address info to Hints
    CopyMemory sa_UDPdest, ByVal Hints.ai_addr, LenB(sa_UDPdest)    'Save sockaddr portion
    API_FreeAddrInfo (ptrResult) ' free the linked list
    If SocketExists Then
        UDPInit = True
        Exit Function
    End If
    'Populate the local sockaddr
    sa_local.sa_family = IPFamily
    sa_local.sa_data(0) = PeekB(VarPtr(LocalPort) + 1)
    sa_local.sa_data(1) = PeekB(VarPtr(LocalPort))
    'Bind to socket
    lRet = API_Bind(m_hSocket, sa_local, LenB(sa_local))
    If lRet = SOCKET_ERROR Then
        m_State = sckError
        Call m_Callback.Error(m_Index, lRet, GetErrorDescription(lRet), Routine)
    Else
        m_State = sckOpen
        UDPInit = True
    End If
End Function

Private Sub Class_Initialize()
    Initialize
End Sub


Private Sub Class_Terminate()
    'clean processes and finish winsock service
    Call modSocket.Finalize
End Sub