Attribute VB_Name = "SocketModule"
Option Explicit

Public Sockets As New Collection
Public UsedCount As Integer
Public UsedSSLCount As Integer

Public Const FD_SETSIZE = 64

Public Const sockClosed = 1
Public Const sockListening = 2
Public Const sockConnecting = 3
Public Const sockConnected = 4

Public Type fd_set
    fd_count As Integer
    fd_array(FD_SETSIZE) As Integer
End Type

Public Type timeval
    tv_sec As Long
    tv_usec As Long
End Type

Public Type Inet_address
    Byte4 As String * 1
    Byte3 As String * 1
    Byte2 As String * 1
    Byte1 As String * 1
End Type

Public Type HostEnt
    h_name As Long
    h_aliases As Long
    h_addrtype As Integer
    h_length As Integer
    h_addr_list As Long
End Type

Public Const hostent_size = 16

Public Type servent
    s_name As Long
    s_aliases As Long
    s_port As Integer
    s_proto As Long
End Type

Public Const servent_size = 14

Public Type protoent
    p_name As Long
    p_aliases As Long
    p_proto As Integer
End Type

Public Const protoent_size = 10

Public Const IPPROTO_TCP = 6
Public Const IPPROTO_UDP = 17

Public Const INADDR_NONE = &HFFFF
Public Const INADDR_ANY = &H0

Public Type sockaddr
    sin_family As Integer
    sin_port As Integer
    sin_addr As Long
    sin_zero As String * 8
End Type

Public Type sockaddrbyte
    sin_family As Integer
    sin_port As Integer
    sin_addr1 As Byte
    sin_addr2 As Byte
    sin_addr3 As Byte
    sin_addr4 As Byte
    sin_zero As String * 8
End Type

Public Const sockaddr_size = 16
Public saZero As sockaddr

Public Const WSA_DESCRIPTIONLEN = 256
Public Const WSA_DescriptionSize = WSA_DESCRIPTIONLEN + 1

Public Const WSA_SYS_STATUS_LEN = 128
Public Const WSA_SysStatusSize = WSA_SYS_STATUS_LEN + 1

Public Type WSADataType
    wVersion As Integer
    wHighVersion As Integer
    szDescription As String * WSA_DescriptionSize
    szSystemStatus As String * WSA_SysStatusSize
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpVendorInfo As Long
End Type

Public Const INVALID_SOCKET = -1
Public Const SOCKET_ERROR = -1

Public Const SOCK_STREAM = 1
Public Const SOCK_DGRAM = 2

Public Const MAXGETHOSTSTRUCT = 1024

Public Const AF_INET = 2
Public Const PF_INET = 2

Public Type LingerType
    l_onoff As Integer
    l_linger As Integer
End Type

'---Windows System Functions
Public Declare Sub MemCopy Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, ByVal Src As Any, ByVal cb As Long)
Public Declare Sub MemCopyEx Lib "kernel32" Alias "RtlMoveMemory" (ByVal Dest As Long, Src As Any, ByVal cb As Long)
Public Declare Sub MemCopyRev Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, ByVal Src As Long, ByVal cb As Long)
Public Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
Public Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Any) As Long
'---async notification constants
Public Const SOL_SOCKET = &HFFFF&   ' = 65535
Public Const SO_LINGER = &H80&  ' = 128
Public Const FD_READ = &H1& ' = 1
Public Const FD_WRITE = &H2&    ' = 2
Public Const FD_ACCEPT = &H8&   ' = 8
Public Const FD_CONNECT = &H10& ' = 16
Public Const FD_CLOSE = &H20&   ' = 32
'---SOCKET FUNCTIONS
Public Declare Function acceptsocket Lib "wsock32.dll" Alias "accept" (ByVal S As Long, addr As sockaddr, addrlen As Long) As Long
Public Declare Function bind Lib "wsock32.dll" (ByVal S As Long, addr As sockaddr, ByVal namelen As Long) As Long
Public Declare Function closesocket Lib "wsock32.dll" (ByVal S As Long) As Long
Public Declare Function connectsocket Lib "wsock32.dll" Alias "connect" (ByVal S As Long, addr As sockaddr, ByVal namelen As Long) As Long
Public Declare Function ioctlsocket Lib "wsock32.dll" (ByVal S As Long, ByVal cmd As Long, argp As Long) As Long
Public Declare Function getpeername Lib "wsock32.dll" (ByVal S As Long, sname As Any, namelen As Long) As Long
Public Declare Function getsockname Lib "wsock32.dll" (ByVal S As Long, sname As sockaddr, namelen As Long) As Long
Public Declare Function getsockopt Lib "wsock32.dll" (ByVal S As Long, ByVal level As Long, ByVal optname As Long, optval As Any, optlen As Long) As Long
Public Declare Function setsockopt Lib "wsock32.dll" (ByVal S As Long, ByVal level As Long, ByVal optname As Long, optval As Any, ByVal optlen As Long) As Long
Public Declare Function htonl Lib "wsock32.dll" (ByVal hostlong As Long) As Long
Public Declare Function htons Lib "wsock32.dll" (ByVal hostshort As Long) As Integer
Public Declare Function inet_addr Lib "wsock32.dll" (ByVal cp As String) As Long
Public Declare Function inet_ntoa Lib "wsock32.dll" (ByVal inn As Long) As Long
Public Declare Function listensocket Lib "wsock32.dll" Alias "listen" (ByVal S As Long, ByVal backlog As Long) As Long
Public Declare Function ntohl Lib "wsock32.dll" (ByVal netlong As Long) As Long
Public Declare Function ntohs Lib "wsock32.dll" (ByVal netshort As Long) As Integer
Public Declare Function recv Lib "wsock32.dll" (ByVal S As Long, buf As Any, ByVal buflen As Long, ByVal FLAGS As Long) As Long
Public Declare Function binRecv Lib "wsock32.dll" Alias "recv" (ByVal S As Long, ByVal buf As Long, ByVal buflen As Long, ByVal FLAGS As Long) As Long
Public Declare Function send Lib "wsock32.dll" (ByVal S As Long, buf As Any, ByVal buflen As Long, ByVal FLAGS As Long) As Long
Public Declare Function binSend Lib "wsock32.dll" Alias "send" (ByVal S As Long, ByVal buf As Long, ByVal buflen As Long, ByVal FLAGS As Long) As Long
Public Declare Function Socket Lib "wsock32.dll" Alias "socket" (ByVal af As Long, ByVal s_type As Long, ByVal Protocol As Long) As Long
'---DATABASE FUNCTIONS
Public Declare Function gethostbyaddr Lib "wsock32.dll" (addr As Long, ByVal addr_len As Long, ByVal addr_type As Long) As Long
Public Declare Function gethostbyname Lib "wsock32.dll" (ByVal host_name As String) As Long
Public Declare Function gethostname Lib "wsock32.dll" (ByVal host_name As String, ByVal namelen As Long) As Long
Public Declare Function getprotobynumber Lib "wsock32.dll" (ByVal proto As Integer) As Long
Public Declare Function getprotobyname Lib "wsock32.dll" (ByVal proto_name As String) As Long
Public Declare Function getservbyport Lib "wsock32.dll" (ByVal Port As Long, ByVal proto As String) As Long
Public Declare Function getservbyname Lib "wsock32.dll" (ByVal serv_name As String, ByVal proto As String) As Long
'---WINDOWS EXTENSIONS
Public Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVR As Long, lpWSAD As WSADataType) As Long
Public Declare Function WSACleanup Lib "wsock32.dll" () As Long
Public Declare Sub WSASetLastError Lib "wsock32.dll" (ByVal iError As Long)
Public Declare Function WSAGetLastError Lib "wsock32.dll" () As Long
Public Declare Function WSAAsyncSelect Lib "wsock32.dll" (ByVal S As Long, ByVal hwnd As Long, ByVal wMsg As Long, ByVal lEvent As Long) As Long

'---SSL VERSCHLÜSSELUNG
Public Declare Function SSLDllGetVersionString Lib "OpenSSL.dll" (ByVal version As String, ByVal Size As String) As Long
Public Declare Function SSLStartup Lib "OpenSSL.dll" (ByVal hPlugInWnd As Long) As Long
Public Declare Function SSLCleanup Lib "OpenSSL.dll" () As Long
Public Declare Function SSLConnect Lib "OpenSSL.dll" (ByVal sock As Long, ByVal ServerFrameID As Long, ByVal Accept_invalide_Certificate As Long, ByVal hostName As String) As Long
Public Declare Function SSLDisconnect Lib "OpenSSL.dll" (ByVal sock As Long) As Long
Public Declare Function SSLSend Lib "OpenSSL.dll" (ByVal sock As Long, ByVal buf As Any, ByVal buflen As Long) As Long
Public Declare Function SSLSendBin Lib "OpenSSL.dll" Alias "SSLSend" (ByVal sock As Long, ByVal buf As Long, ByVal buflen As Long) As Long
Public Declare Function SSLRecv Lib "OpenSSL.dll" (ByVal sock As Long, buf As Any, ByVal buflen As Long) As Long
Public Declare Function SSLRecvBin Lib "OpenSSL.dll" Alias "SSLRecv" (ByVal sock As Long, ByVal buf As Long, ByVal buflen As Long) As Long

' ICMP
Public Type IP_OPTION_INFORMATION
    TTL As Byte                   ' Time to Live (used for traceroute)
    Tos As Byte                   ' Type of Service (usually 0)
    FLAGS As Byte                 ' IP header Flags (usually 0)
    OptionsSize As Long           ' Size of Options data (usually 0, max 40)
    OptionsData As String * 128   ' Options data buffer
End Type

Public Type IP_ECHO_REPLY
    Address(0 To 3) As Byte           ' Replying Address
    Status As Long                    ' Reply Status
    RoundTripTime As Long             ' Round Trip Time in milliseconds
    DataSize As Integer               ' reply data size
    Reserved As Integer               ' for system use
    Data As Long                      ' pointer to echo data
    Options As IP_OPTION_INFORMATION  ' Reply Options
End Type

Public Const WS_OVERLAPPED = &H0&
Public Const WS_MINIMIZEBOX = &H20000
Public Const WS_MAXIMIZEBOX = &H10000
Public Const WS_SYSMENU = &H80000
Public Const WS_THICKFRAME = &H40000
Public Const WS_CAPTION = &HC00000                  '  WS_BORDER Or WS_DLGFRAME
Public Const WS_VISIBLE = &H10000000
Public Const WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)

Public Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long

Public Function GetAscIp(ByVal inn As Long) As String
  On Error Resume Next
  Dim lpStr As Long
  Dim nStr As Long
  Dim retString As String
  
  retString = String(32, 0)
  lpStr = inet_ntoa(inn)
  If lpStr = 0 Then
    GetAscIp = ""
    Exit Function
  End If
  nStr = lstrlen(lpStr)
  If nStr > 32 Then nStr = 32
  MemCopy ByVal retString, ByVal lpStr, nStr
  retString = Left(retString, nStr)
  GetAscIp = retString
  If Err Then GetAscIp = ""
End Function

Public Function GetHostByNameAlias(ByVal hostName As String) As Long
  On Error Resume Next
  'Return IP address as a long, in network byte order

  Dim phe As Long     ' pointer to host information entry
  Dim heDestHost As HostEnt 'hostent structure
  Dim addrList As Long
  Dim retIP As Long
  'first check to see if what we have been passed is a valid IP
  retIP = inet_addr(hostName)
  If retIP = INADDR_NONE Then
    'it wasn't an IP, so do a DNS lookup
    phe = gethostbyname(hostName)
    If phe <> 0 Then
      'Pointer is non-null, so copy in hostent structure
      MemCopy heDestHost, ByVal phe, hostent_size
      'Now get first pointer in address list
      MemCopy addrList, ByVal heDestHost.h_addr_list, 4
      MemCopy retIP, ByVal addrList, heDestHost.h_length
    Else
      'its not a valid address
      retIP = INADDR_NONE
    End If
  End If
  GetHostByNameAlias = Trim(retIP)
  If Err Then GetHostByNameAlias = INADDR_NONE
End Function

Public Function GetHostByAddress(ByVal addr As Long) As String
  On Error Resume Next
  Dim phe As Long
  Dim Ret As Long
  Dim heDestHost As HostEnt
  Dim hostName As String
  
  phe = gethostbyaddr(addr, 4, PF_INET)
  If phe <> 0 Then
    MemCopy heDestHost, ByVal phe, hostent_size
    hostName = String(256, 0)
    MemCopy ByVal hostName, ByVal heDestHost.h_name, 256
    GetHostByAddress = Left(hostName, InStr(hostName, Chr(0)) - 1)
  Else
    GetHostByAddress = ""
  End If
  If Err Then GetHostByAddress = ""
End Function

Public Function AddrToIP(ByVal AddrOrIP As String) As String
  AddrToIP = GetAscIp(GetHostByNameAlias(AddrOrIP))
End Function

'Public Function IpToAddr(ByVal AddrOrIP As String) As String
'  On Error Resume Next
'  IpToAddr = GetHostByAddress(GetHostByNameAlias(AddrOrIP))
'  If Err Then IpToAddr = ""
'End Function

'Public Function DNSLookup(ByVal Address As String) As String
'  If inet_addr(Address) <> INADDR_NONE Then
'    DNSLookup = IpToAddr(Address)
'  ElseIf gethostbyname(Address) <> 0 Then
'    DNSLookup = AddrToIP(Address)
'  End If
'End Function

Public Function GetLocalHostName() As String
  Dim dummy As Long
  Dim LocalName As String
  Dim S As String
  On Error Resume Next
  LocalName = String(256, 0)
  LocalName = ""
  dummy = 1
  S = String(256, 0)
  dummy = gethostname(S, 256)
  If dummy = 0 Then
    S = Left(S, InStr(S, Chr(0)) - 1)
    If Len(S) > 0 Then
      LocalName = S
    End If
  End If
  GetLocalHostName = Trim(LocalName)
  If Err Then GetLocalHostName = ""
End Function

Public Function LongIP(ByVal IPAddress As String) As String
  On Error GoTo longipError
  Dim nStr As Long
  Dim retString As String
  Dim lpStr As Long
  Dim inn As Long
  If InStr(IPAddress, ".") = 0 Then
    If Val(IPAddress) > 2147483647 Then
      inn = Val(IPAddress) - 4294967296#
    Else
      inn = Val(IPAddress)
    End If
    inn = ntohl(inn)
    retString = String(32, 0)
    lpStr = inet_ntoa(inn)
    If lpStr = 0 Then
      LongIP = "0.0.0.0"
      Exit Function
    End If
    nStr = lstrlen(lpStr)
    If nStr > 32 Then nStr = 32
    MemCopy ByVal retString, ByVal lpStr, nStr
    retString = Left(retString, nStr)
    LongIP = retString
    Exit Function
longipError:
    LongIP = ""
    Exit Function
    Resume
  Else
    inn = inet_addr(IPAddress)
    inn = htonl(inn)
    If inn < 0 Then
      LongIP = CVar(inn + 4294967296#)
    Else
      LongIP = CVar(inn)
    End If
  End If
End Function

Public Function WSAGetSelectEvent(ByVal lParam As Long) As Integer
  If (lParam And &HFFFF&) > &H7FFF Then
    WSAGetSelectEvent = (lParam And &HFFFF&) - &H10000
  Else
    WSAGetSelectEvent = lParam And &HFFFF&
  End If
End Function

Public Function WSAGetAsyncError(ByVal lParam As Long) As Integer
  WSAGetAsyncError = (lParam And &HFFFF0000) \ &H10000
End Function

Public Function GetWSAErrorString(ByVal errnum As Long) As String
  Select Case errnum
    Case 10004: GetWSAErrorString = "Interrupted system call."
    Case 10009: GetWSAErrorString = "Bad file number."
    Case 10013: GetWSAErrorString = "Permission Denied."
    Case 10014: GetWSAErrorString = "Bad Address."
    Case 10022: GetWSAErrorString = "Invalid Argument."
    Case 10024: GetWSAErrorString = "Too many open files."
    Case 10035: GetWSAErrorString = "Operation would block."
    Case 10036: GetWSAErrorString = "Operation now in progress."
    Case 10037: GetWSAErrorString = "Operation already in progress."
    Case 10038: GetWSAErrorString = "Socket operation on nonsocket."
    Case 10039: GetWSAErrorString = "Destination address required."
    Case 10040: GetWSAErrorString = "Message too long."
    Case 10041: GetWSAErrorString = "Protocol wrong type for socket."
    Case 10042: GetWSAErrorString = "Protocol not available."
    Case 10043: GetWSAErrorString = "Protocol not supported."
    Case 10044: GetWSAErrorString = "Socket type not supported."
    Case 10045: GetWSAErrorString = "Operation not supported on socket."
    Case 10046: GetWSAErrorString = "Protocol family not supported."
    Case 10047: GetWSAErrorString = "Address family not supported by protocol family."
    Case 10048: GetWSAErrorString = "Address already in use."
    Case 10049: GetWSAErrorString = "Can't assign requested address."
    Case 10050: GetWSAErrorString = "Network is down."
    Case 10051: GetWSAErrorString = "Network is unreachable."
    Case 10052: GetWSAErrorString = "Network dropped connection."
    Case 10053: GetWSAErrorString = "Software caused connection abort."
    Case 10054: GetWSAErrorString = "Connection reset by peer."
    Case 10055: GetWSAErrorString = "No buffer space available."
    Case 10056: GetWSAErrorString = "Socket is already connected."
    Case 10057: GetWSAErrorString = "Socket is not connected."
    Case 10058: GetWSAErrorString = "Can't send after socket shutdown."
    Case 10059: GetWSAErrorString = "Too many references: can't splice."
    Case 10060: GetWSAErrorString = "Connection timed out."
    Case 10061: GetWSAErrorString = "Connection refused."
    Case 10062: GetWSAErrorString = "Too many levels of symbolic links."
    Case 10063: GetWSAErrorString = "File name too long."
    Case 10064: GetWSAErrorString = "Host is down."
    Case 10065: GetWSAErrorString = "No route to host."
    Case 10066: GetWSAErrorString = "Directory not empty."
    Case 10067: GetWSAErrorString = "Too many processes."
    Case 10068: GetWSAErrorString = "Too many users."
    Case 10069: GetWSAErrorString = "Disk quota exceeded."
    Case 10070: GetWSAErrorString = "Stale NFS file handle."
    Case 10071: GetWSAErrorString = "Too many levels of remote in path."
    Case 10091: GetWSAErrorString = "Network subsystem is unusable."
    Case 10092: GetWSAErrorString = "Winsock DLL cannot support this application."
    Case 10093: GetWSAErrorString = "Winsock not initialized."
    Case 10101: GetWSAErrorString = "Disconnect."
    Case 11001: GetWSAErrorString = "Host not found."
    Case 11002: GetWSAErrorString = "Nonauthoritative host not found."
    Case 11003: GetWSAErrorString = "Nonrecoverable error."
    Case 11004: GetWSAErrorString = "Valid name, no data record of requested type."
    Case Else:
  End Select
End Function

Public Function SetSockLinger(ByVal SockNum As Long, ByVal onoff As Integer, ByVal LingerTime As Integer) As Long
  Dim Linger As LingerType
  Linger.l_onoff = onoff
  Linger.l_linger = LingerTime
  If setsockopt(SockNum, SOL_SOCKET, SO_LINGER, Linger, 4) Then
    SetSockLinger = SOCKET_ERROR
  Else
    If getsockopt(SockNum, SOL_SOCKET, SO_LINGER, Linger, 4) Then
      SetSockLinger = SOCKET_ERROR
    End If
  End If
End Function

Public Function GetPeerHostByAddr(Socket As Long) As String
  Dim sock As sockaddrbyte
  Call getpeername(Socket, sock, sockaddr_size)
  GetPeerHostByAddr = sock.sin_addr1 & "." & sock.sin_addr2 & "." & sock.sin_addr3 & "." & sock.sin_addr4
End Function

Public Function GetPeerHostByName(Socket As Long) As String
  Dim sock As sockaddr
  Call getpeername(Socket, sock, sockaddr_size)
  GetPeerHostByName = GetHostByAddress(sock.sin_addr)
End Function

Public Function GetPeerPort(Socket As Long) As Long
  Dim sock As sockaddr
  Dim P As Integer
  
  Call getpeername(Socket, sock, sockaddr_size)
  P = ntohs(sock.sin_port)
  If P < 0 Then GetPeerPort = P + 65536 Else GetPeerPort = P
End Function

Public Function GetLocalHost(Socket As Long) As String
  Dim sock As sockaddr
  Call getsockname(Socket, sock, sockaddr_size)
  GetLocalHost = GetHostByAddress(sock.sin_addr)
End Function

Public Function GetLocalIP(Socket As Long) As String
  Dim sock As sockaddr
  Call getsockname(Socket, sock, sockaddr_size)
  GetLocalIP = LongIP(sock.sin_addr)
End Function

Public Function GetLocalPort(Socket As Long) As Long
  Dim sock As sockaddr
  Dim P As Integer
  
  Call getsockname(Socket, sock, sockaddr_size)
  P = ntohs(sock.sin_port)
  If P < 0 Then GetLocalPort = P + 65536 Else GetLocalPort = P
End Function

Public Function SetWindowProc(hwnd As Long, func As Long) As Long
  If func Then
    SetWindowProc = SetWindowLongA(hwnd, GWL_WNDPROC, func)
  Else
    SetWindowProc = SetWindowLongA(hwnd, GWL_WNDPROC, AddressOf WindowProc)
  End If
End Function

Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal WParam As Long, ByVal lParam As Long) As Long
  Dim S As CSocket
  Dim n As Integer
  Dim er As String
    
  Set S = Nothing
  
  If uMsg <> 2000 Then
    For n = 1 To Sockets.Count
      If Sockets(n).WindowHandle = hwnd Then Set S = Sockets(n): Exit For
    Next
    If S.WindowProcOld Then
      WindowProc = CallWindowProcA(S.WindowProcOld, hwnd, uMsg, WParam, lParam)
    End If
    Exit Function
  End If
    
  For n = 1 To Sockets.Count
    If Sockets(n).SocketHandle = WParam Then Set S = Sockets(n): Exit For
  Next
  If S Is Nothing Then Exit Function
  
  
  Dim WSAEvent As Long, WSAError As Long
  WSAEvent = WSAGetSelectEvent(lParam)
  WSAError = WSAGetAsyncError(lParam)
    
  Select Case WSAEvent ' Determine Event
  Case FD_CLOSE ' Socket Close
    S.WindowProc WSAEvent, 0
  Case FD_CONNECT
    If WSAError = 0 Then ' No Error, Connected
      S.WindowProc WSAEvent, 0
    Else ' Error, Not Connected
      er = GetWSAErrorString(WSAError)
      closesocket WParam
      S.WindowProc 0, er
    End If
  Case FD_ACCEPT
    S.WindowProc WSAEvent, 0
  Case FD_READ
    S.WindowProc WSAEvent, 0
  Case FD_WRITE
    S.WindowProc WSAEvent, 0
  End Select
End Function


