vbsock.bas

运行多用户

  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:  GetWSAErrorString = "Unknown Error..."
  End Select
End Function

Public Function args_ctrl(ArgS As String, Type_Args As String, ByRef argument() As String) As Integer
  Dim Dummy As String
  Dim len_args As Integer, i As Integer, ascii As Integer
  Dim s As Integer, e As Integer
  Dim S1 As String
  
  ReDim h(6) As Long
  
  'the arguments of type <username>, <password> and
  '<pathname> are strings
  If Type_Args = "username" Or Type_Args = "password" _
  Or Type_Args = "pathname" Then
    Type_Args = "string"
  End If
  
  'command Ok
  args_ctrl = 0
  
  len_args = Len(ArgS)
  
  Select Case Type_Args
  
  Case "string" '<string>  <string:= char | char&string>
    For i = 1 To len_args
      ascii = Asc(Mid$(ArgS, i, 1))
      If ascii < 32 Or ascii > 126 Then      'only printable characters
        args_ctrl = 3           'sintax error in parameters or arguments
        Exit For
      End If
    Next
    argument(0) = ArgS

  Case "host-port" '<h1,h2,h3,h4,p1,p2>  <h?:=1..255>  <p?:=1..255>
    '<Host> is formed by 4 elements, divided by comma, which representing IP address;
    '<port> is formed by 2 elements, divided by comma, which representing the MSB and LSB of the port.
    'add a separator for simplifing the procedure
    Dummy = ArgS & ","
    Debug.Print "Port String = " & Dummy
    e = 1    'point to next element
    For i = 1 To 6
      s = InStr(e, Dummy, ",") 's point to next separator (ie. comma)
      If s = 0 Then
        args_ctrl = 3          'sintax error in parameters or arguments
        Exit For
      Else
        'every element of the argument must be an integer,
        'represented as string, in the range 1 to 255
        h(i) = Val(Mid$(Dummy, e, s - e))
        Debug.Print "h(" & CStr(i) & ") = " & h(i)
        If h(i) < 0 Or h(i) > 255 Then
          args_ctrl = 3       'sintax error in parameters or arguments
          Exit For
        End If
      End If
      e = s + 1       'point to next element
    Next
    argument(0) = Format$(h(1))              'IP address
    argument(1) = Format$(h(2))
    argument(2) = Format$(h(3))
    argument(3) = Format$(h(4))
    argument(4) = Format$(h(5) * 256 + h(6)) 'port
  
  Case "type-code"  '<A [A N] | I>
    S1 = InStr(ArgS, " ")
    If S1 = 0 Then
      If ArgS = "A" Or ArgS = "" Then
        'arguments assume default values
        argument(0) = "A"  'Ascii
        argument(1) = "N"  'No print
      ElseIf ArgS = "E" Then
        'command not implemented for that parameter
        args_ctrl = 6
        argument(0) = ArgS
      ElseIf ArgS = "I" Then
        argument(0) = "I"
      Else
        'sintax error in parameters or arguments
        args_ctrl = 3
        argument(0) = ArgS
      End If
    Else
      If Left$(ArgS, S1 - 1) = "A" Then
        argument(0) = "A"
        While Mid$(ArgS, S1, 1) = " "
          S1 = S1 + 1
        Wend
        If Mid$(ArgS, S1) = "" Or Mid$(ArgS, S1) = "N" Then
          argument(1) = "N"
        ElseIf Mid$(ArgS, S1) = "T" Then
          'command not implemented for that parameter
          args_ctrl = 6
          argument(1) = Mid$(ArgS, S1)
        ElseIf Mid$(ArgS, S1) = "C" Then
          'command not implemented for that parameter
          args_ctrl = 6
          argument(1) = Mid$(ArgS, S1)
        Else
          'sintax error in parameters or arguments
          args_ctrl = 3
          argument(1) = Mid$(ArgS, S1)
        End If
      ElseIf Left$(ArgS, S1 - 1) = "L" Then
        'command not implemented for that parameter
        args_ctrl = 6
        argument(1) = Mid$(ArgS, S1)
      ElseIf Left$(ArgS, S1 - 1) = "I" Then
        argument(0) = "I"
      Else
        'sintax error in parameters or arguments
        args_ctrl = 3
        argument(0) = Left$(ArgS, S1 - 1)
      End If
    End If
  
  Case "mode-code"  '<S>
    If ArgS = "" Or ArgS = "S" Then
      'argument assumes default value
      argument(0) = "S"  'Stream
    ElseIf ArgS = "B" Then
      'command not implemented for that parameter
      args_ctrl = 6
      argument(0) = ArgS
    ElseIf ArgS = "C" Then
      'command not implemented for that parameter
      args_ctrl = 6
      argument(0) = ArgS
    Else
      'sintax error in parameters or arguments
      args_ctrl = 3
      argument(0) = Left$(ArgS, S1 - 1)
    End If

  Case "structure-code"  '<F | R>
    If ArgS = "" Or ArgS = "F" Then
      'argument assumes default value
      argument(0) = "F" 'File
    ElseIf ArgS = "R" Then
      'command not implemented for that parameter
      args_ctrl = 6
      argument(0) = ArgS
    ElseIf ArgS = "P" Then
      'command not implemented for that parameter
      args_ctrl = 6
      argument(0) = ArgS
    Else
      'sintax error in parameters or arguments
      args_ctrl = 3
      argument(0) = ArgS
    End If
  
  End Select

End Function

Public Function close_data_connect(ID_User As Integer) As Integer
  
  retf = closesocket(users(ID_User).data_slot)
  If retf = 0 Then
    'updates user record
    users(ID_User).data_slot = INVALID_SOCKET
    users(ID_User).IP_Address = ""
    users(ID_User).Port = 0
    users(ID_User).State = Service_Commands ' 2
  End If
  close_data_connect = retf

End Function

Public Function logoff(ID_User As Integer) As Integer

  retf = send_reply("221 Closing control connection, GoodBye!", ID_User)
  retf = closesocket(users(ID_User).control_slot)
  If retf = 0 Then
    're-initialize the record containing user informations
    users(ID_User).list_index = 0
    users(ID_User).control_slot = INVALID_SOCKET
    users(ID_User).data_slot = INVALID_SOCKET
    users(ID_User).IP_Address = ""
    users(ID_User).Port = 0
    users(ID_User).data_representation = "A"
    users(ID_User).data_format_ctrls = "N"
    users(ID_User).data_structure = "F"
    users(ID_User).data_tx_mode = "S"
    users(ID_User).cur_dir = ""
    users(ID_User).State = Log_In_Out ' 0
    users(ID_User).full = False
    users(ID_User).Jenny.Terminate
    Set users(ID_User).Jenny = Nothing
  Else
 '   frmFTP.StatusBar.Panels(1) = "Error: Couldn't Close Connection!"
  End If
  num_users = num_users - 1
 ' frmFTP.UsrCnt = CStr(num_users)
  logoff = retf

End Function

Public Function open_data_connect(ID_User As Integer) As Integer
  
  'open data connection
  retf = send_reply("150 Open data connection.", ID_User)
  open_data_connect = retf

End Function

Public Function receive_data(RecvBuffer As String, ID_User As Integer) As Integer
  Dim fixstr As String * 1024

  'receives data on connection
  retf = recv(users(ID_User).data_slot, fixstr, 1024, 0)
  If retf > 0 Then
    RecvBuffer = Left$(fixstr, retf)
  End If
  receive_data = retf

End Function

Public Function send_data(data_ As String, ID_User As Integer) As Integer
  Dim WriteBuffer As String
  Dim lenBuffer As Integer

  'sends data on connection
  WriteBuffer = data_
  lenBuffer = Len(WriteBuffer)
  retf = send(users(ID_User).data_slot, WriteBuffer, lenBuffer, 0)
  send_data = retf

End Function

Public Function send_reply(reply As String, ID_User As Integer) As Integer
  Dim WriteBuffer As String
  Dim lenBuffer As Integer

  WriteBuffer = reply & vbCrLf
  lenBuffer = Len(WriteBuffer)
  retf = send(users(ID_User).control_slot, WriteBuffer, lenBuffer, 0)
  If retf = SOCKET_ERROR Then
'    ServerLog "Error sending reply:" & CStr(retf)
  Else
    'log replies
'    ServerLog "<" & Format$(ID_User, "000") & "> " & Format$(Date$, "dd/mm/yy ") & Format$(Time$, "hh:mm - ") & reply
  End If
  send_reply = retf

End Function

Public Function sintax_ctrl(cmd As String, ByRef Kwrd As String, ByRef argument() As String) As Integer
  Dim ArgS As String
  Dim k As Integer
  Dim len_cmd As Integer
  
  'the command must be terminated by CR&LF characters
  len_cmd = InStr(cmd, vbCrLf) - 1
  If len_cmd = 0 Then
    sintax_ctrl = 2 'sintax error, command unrecognized
    Exit Function
  Else
    'suppresses CR&LF characters
    cmd = Left$(cmd, len_cmd)
  End If
  
  'extract keyword
  k = InStr(cmd, " ")
  If k <> 0 Then
    'command with arguments