vbsock.bas

运行多用户

Attribute VB_Name = "VBSOCK"
Option Explicit

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb&)
Public Declare Function lstrlen Lib "kernel32" (ByVal lpString As Any) As Integer

Public DnsHost As String
Public MaxSockets As Integer
Public MaxUDP As Long
Public Description As String
Public Status As String
Public sintax_error_list(10) As String 'the list of the messages which signal a sintax error in a FTP command

Public users(MAX_N_USERS) As User

Public Type file_info
  Full_Name As String
  data_representation As String * 1
  open_file As Integer
  retr_stor As Integer  '0=RETR; 1=STOR
  Buffer As String  'contains data to send
  File_Len As Long  '--- Binary mode only
  blocks As Long  'number of 1024 bytes blocks in file
  spare_bytes As Long
  next_block As Long  'next block to send
  next_byte As Long  'points to position in file of the next block to send
  try_again As Integer  'if try_again=true the old line is sent =Ascii mode only
End Type

Public files_info(5) As file_info

'contains error during function call
Public retf As Integer

'*** Variables used during TCP/IP exchange
'slot number assigned to Server
Public ServerSlot As Long
'number of clients connected to server
Public num_users As Integer
Public ListenSock As Long
Public NewSlot As Long

'-------------------------------------
'used by jenny
 Public FTP_Index As Integer
 Public FTP_Command As String
 Public FTP_Args() As String

Function ConnectSocket(ByVal hWndtyp As Long, ByVal Host As String, ByVal Port As Integer) As Long
  Dim SockreadBuffer As String, RetIpPort As String
  Dim s As Long, Dummy As Long
  'Dim NewSock As SockAddr
  Dim SelectOps As Integer
    
    SockreadBuffer = ""
    SockAddr.sin_family = AF_INET
    SockAddr.sin_port = htons(Port)
    If Val(SockAddr.sin_zero) = INVALID_SOCKET Then
        ConnectSocket = INVALID_SOCKET
        Exit Function
    End If
    SockAddr.sin_addr = GetHostByNameAlias(Host)
    If SockAddr.sin_addr = INADDR_NONE Then
        ConnectSocket = INVALID_SOCKET
        Exit Function
    End If
    RetIpPort = GetAscIP(SockAddr.sin_addr) & ":" & ntohs(SockAddr.sin_port)
    Debug.Print RetIpPort
    s = Socket(PF_INET, SOCK_STREAM, IPPROTO_TCP)
    If s < 0 Then
        ConnectSocket = INVALID_SOCKET
        Exit Function
    End If
    'If SetSockLinger(S, 1, 0) = SOCKET_ERROR Then
    '    If S > 0 Then
    '       Dummy = closesocket(S)
    '    End If
    '    ConnectSocket = INVALID_SOCKET
    '    Exit Function
    'End If
    SelectOps = FD_CONNECT Or FD_READ Or FD_WRITE Or FD_CLOSE Or FD_ACCEPT
    If WSAAsyncSelect(s, hWndtyp, ByVal 5152, ByVal SelectOps) Then
        If s > 0 Then
            Dummy = closesocket(s)
        End If
        ConnectSocket = INVALID_SOCKET
        Exit Function
    End If
    If connect(s, SockAddr, SockAddr_Size) <> -1 Then
        If s > 0 Then
            Dummy = closesocket(s)
        End If
        ConnectSocket = INVALID_SOCKET
        Exit Function
    End If
    ConnectSocket = s
End Function

Function WSAGetSelectEvent(ByVal lParam As Long) As Long
    WSAGetSelectEvent = Int(lParam Mod 65536)
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 Long
    WSAGetAsyncError = (lParam And &HFFFF0000) \ &H10000
End Function

Function DNS_Lookup(ByVal dnsip As String) As String
  DnsHost = ""
  vbWSAStartup
  DoEvents
  DNS_Lookup = vbGetHostByAddress(dnsip)
  DoEvents
  vbWSACleanup
End Function

Function vbGetHostByAddress(ByVal sAddress As String) As String
  Dim lAddress As Long
  Dim PointerToMemoryLocation As Long
  Dim HostName As String
  Dim hostent As hostent
  lAddress = inet_addr(sAddress)
  PointerToMemoryLocation = gethostbyaddr(lAddress, 4, PF_INET)
  If PointerToMemoryLocation <> 0 Then
    CopyMemory hostent, ByVal PointerToMemoryLocation, Len(hostent)
    HostName = String(256, 0)
    CopyMemory ByVal HostName, ByVal hostent.h_name, 256
    If HostName = "" Then
      vbGetHostByAddress = "Unable to Resolve Address"
    Else
      vbGetHostByAddress = Left(HostName, InStr(HostName, Chr(0)) - 1)
    End If
  Else
    vbGetHostByAddress = "No DNS Entry"
  End If
End Function

Function LoByte(ByVal wParam As Integer)
  LoByte = wParam And &HFF&
End Function

Function HiByte(ByVal wParam As Integer)
  HiByte = wParam / &H100 And &HFF&
End Function

Sub vbWSAStartup()
  Dim iReturn As Integer
  Dim sHighByte As String
  Dim sLowByte As String
  Dim sMsg As String
  Dim i As Integer
  iReturn = WSAStartup(&H101, WSAdata)
   If LoByte(WSAdata.wVersion) < WS_VERSION_MAJOR Or _
    (LoByte(WSAdata.wVersion) = WS_VERSION_MAJOR _
    And HiByte(WSAdata.wVersion) < WS_VERSION_MINOR) Then
        sHighByte = Trim(str(HiByte(WSAdata.wVersion)))
        sLowByte = Trim(str(LoByte(WSAdata.wVersion)))
    End If
    If WSAdata.iMaxSockets < MIN_SOCKETS_REQD Then
        sMsg = "This application requires a minimum of "
        sMsg = sMsg & Trim$(str$(MIN_SOCKETS_REQD)) & " supported sockets."
    End If
    MaxSockets = WSAdata.iMaxSockets
    If MaxSockets < 0 Then
        MaxSockets = 65536 + MaxSockets
    End If
    MaxUDP = WSAdata.iMaxUdpDg
    If MaxUDP < 0 Then
        MaxUDP = 65536 + MaxUDP
    End If
    Description = WSAdata.szDescription
    Status = ""
    Status = WSAdata.szSystemStatus
End Sub

Sub vbWSACleanup()
  Dim iReturn As Long
  Dim sMsg As String
  iReturn = WSACleanup()
  If iReturn <> 0 Then
    sMsg = "WSock32 Error - " & Trim$(str$(iReturn)) & " occurred in Cleanup"
  End If
End Sub


'returns IP as long, in network byte order
Public Function GetHostByNameAlias(ByVal HostName$) As Long
    'Return IP address as a long, in network byte order
    Dim phe&
    Dim heDestHost As hostent
    Dim addrList&
    Dim retIP&
    retIP = inet_addr(HostName$)
    If retIP = INADDR_NONE Then
        phe = gethostbyname(HostName$)
        If phe <> 0 Then
            CopyMemory heDestHost, ByVal phe, Len(heDestHost)
            CopyMemory addrList, ByVal heDestHost.h_addr_list, 4
            CopyMemory retIP, ByVal addrList, heDestHost.h_length
        Else
            retIP = INADDR_NONE
        End If
    End If
    GetHostByNameAlias = retIP
End Function

Public Function GetAscIP(ByVal inn As Long) As String
  Dim nStr&
  Dim lpStr&
  Dim retString$
  retString = String(32, 0)
  lpStr = inet_ntoa(inn)
  If lpStr Then
    nStr = lstrlen(lpStr)
    If nStr > 32 Then nStr = 32
    CopyMemory ByVal retString, ByVal lpStr, nStr
    retString = Left(retString, nStr)
    GetAscIP = retString
  Else
    GetAscIP = "255.255.255.255"
  End If
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
        Debug.Print "Error setting linger info: " & WSAGetLastError()
        SetSockLinger = SOCKET_ERROR
    Else
        If getsockopt(SockNum, SOL_SOCKET, SO_LINGER, Linger, 4) Then
            Debug.Print "Error getting linger info: " & WSAGetLastError()
            SetSockLinger = SOCKET_ERROR
        Else
            Debug.Print "Linger is on if nonzero: "; Linger.l_onoff
            Debug.Print "Linger time if linger is on: "; Linger.l_linger
        End If
    End If
End Function

Public Function ListenForConnect(ByVal Port&, ByVal HWndToMsg&) As Long
Dim s As Long, Dummy As Long
Dim SelectOps As Integer

    s = Socket(PF_INET, SOCK_STREAM, IPPROTO_TCP)
    If s < 0 Then
        ListenForConnect = INVALID_SOCKET
        Exit Function
    End If
    
    SockAddr.sin_family = AF_INET
    SockAddr.sin_port = htons(Port)
    If SockAddr.sin_port = INVALID_SOCKET Then
        ListenForConnect = INVALID_SOCKET
        Exit Function
    End If
    SockAddr.sin_addr = htonl(INADDR_ANY)
    If SockAddr.sin_addr = INADDR_NONE Then
        ListenForConnect = INVALID_SOCKET
        Exit Function
    End If

    If bind(s, SockAddr, SockAddr_Size) Then
        If s > 0 Then
            Dummy = closesocket(s)
        End If
        ListenForConnect = INVALID_SOCKET
        Exit Function
    End If
    
    If listen(s, 1) Then
        If s > 0 Then
            Dummy = closesocket(s)
        End If
        ListenForConnect = INVALID_SOCKET
        Exit Function
    End If
    
    SelectOps = FD_CONNECT Or FD_READ Or FD_WRITE Or FD_CLOSE Or FD_ACCEPT
    If WSAAsyncSelect(s, HWndToMsg, ByVal 5150, ByVal SelectOps) Then
        If s > 0 Then
            Dummy = closesocket(s)
        End If
        ListenForConnect = SOCKET_ERROR
        Exit Function
    End If
    ListenForConnect = s
End Function

Function GetWSAErrorString(ByVal errnum As Long) As String
  On Error Resume Next
  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."