vbsock.bas

运行多用户

    Kwrd = Left$(cmd, k - 1)  'keyword
    While Mid$(cmd, k, 1) = " "
     k = k + 1
    Wend
    ArgS = Mid$(cmd, k)       'arguments
  Else
    'command without arguments
    Kwrd = cmd
    ArgS = ""
  End If
  
  'command Ok
  sintax_ctrl = 0
  
  Select Case UCase$(Kwrd)
    
  Case "USER"  'USER <username>
    sintax_ctrl = args_ctrl(ArgS, "username", argument())
    
  Case "PASS" 'PASS <password>
    sintax_ctrl = args_ctrl(ArgS, "password", argument())
  
  Case "ACCT"
    sintax_ctrl = 4 'command not implemented
    
  Case "CWD", "XCWD" 'CWD <pathname>
    sintax_ctrl = args_ctrl(ArgS, "pathname", argument())
    
  Case "CDUP", "XCUP"  'CDUP
    '------------------
  
  Case "SMNT"
    sintax_ctrl = 4 'command not implemented
  
  Case "QUIT" 'QUIT
    '-----------------
  
  Case "PORT" 'PORT <host-port>
    sintax_ctrl = args_ctrl(ArgS, "host-port", argument())
  
  Case "PASV"
    sintax_ctrl = 4 'command not implemented
  
  Case "TYPE" 'TYPE <type-code>
    sintax_ctrl = args_ctrl(ArgS, "type-code", argument())
  
  Case "STRU" 'STRU <structure-code>
    sintax_ctrl = args_ctrl(ArgS, "structure-code", argument())
    
  Case "MODE" 'MODE <mode-code>
    sintax_ctrl = args_ctrl(ArgS, "mode-code", argument())
    
  Case "RETR" 'RETR <pathname>
    sintax_ctrl = args_ctrl(ArgS, "pathname", argument())
    
  Case "STOR" 'STOR <pathname>
    sintax_ctrl = args_ctrl(ArgS, "pathname", argument())
    
  Case "RNFR"  'RNFR <pathname>
    sintax_ctrl = args_ctrl(ArgS, "pathname", argument())
    
  Case "RNTO"  'RNTO <pathname>
    sintax_ctrl = args_ctrl(ArgS, "pathname", argument())
    
  Case "ABOR"
    sintax_ctrl = 4 'command not implemented
    
  Case "DELE"  'DELE <pathname>
    sintax_ctrl = args_ctrl(ArgS, "pathname", argument())
    
  Case "RMD", "XRMD" 'RMD <pathname>
    sintax_ctrl = args_ctrl(ArgS, "pathname", argument())
  
  Case "MKD", "XMKD" 'MKD <pathname>
    sintax_ctrl = args_ctrl(ArgS, "pathname", argument())
  
  Case "PWD", "XPWD" 'PWD
    '----------------
  
  Case "LIST" 'LIST <pathname>
    sintax_ctrl = args_ctrl(ArgS, "pathname", argument())
    
  Case "NLST" 'NLST <pathname>
    sintax_ctrl = args_ctrl(ArgS, "pathname", argument())
    
    
  Case "SYST"  'SYST
    '------------------
  
  Case "STAT"  'STAT <pathname>
    sintax_ctrl = args_ctrl(ArgS, "pathname", argument())
  
  Case "HELP"  'HELP <string>
    sintax_ctrl = args_ctrl(ArgS, "string", argument())
    
  Case "NOOP": 'NOOP
    '-----------------
  
  Case "REIN" 'REIN
    sintax_ctrl = 4 'command not implemented
  Case "STOU"
    sintax_ctrl = 4 'command not implemented
  
  Case "APPE"
    sintax_ctrl = 4 'command not implemented
  
  Case "ALLO"
    sintax_ctrl = 1 'command not implemented, superfluous at this side
  
  Case "REST"
    sintax_ctrl = 4 'command not implemented
  
  Case "SITE"
    sintax_ctrl = 4 'command not implemented
  
  Case Else
    sintax_ctrl = 2 'sintax error, command unrecognized
  End Select
  
End Function

Public Sub ServerLog(ByVal str As String)
    
  frmFTP.LogWnd.AddItem str
  frmFTP.LogWnd.Selected(frmFTP.LogWnd.ListCount - 1) = True
End Sub

'EXEC A FTP COMMAND:
'<id_user> is a number in the range 1 to MAX_N_USERS
'identifing the user who sends the command;
'<cmd> is the command.

Public Function ChkPath(ByVal ID_User As Integer, ByVal Arg As String) As String
    If Left$(Arg, 1) = "\" Then
      ChkPath = Left$(users(ID_User).cur_dir, 2) & Arg                  'absolute path
      'ChkPath = DEFAULT_DRIVE & Arg                   'absolute path
    Else
      If Right$(Arg, 1) = ":" And Len(Arg) = 2 Then 'Change Drive letter
        ChkPath = Arg
      ElseIf Right$(users(ID_User).cur_dir, 1) = "\" Then 'relative path
        ChkPath = users(ID_User).cur_dir & Arg        'radix
      Else
        ChkPath = users(ID_User).cur_dir & "\" & Arg
      End If
    End If
End Function

Public Sub SendBuffer(ID_User As Integer, ByRef Buffer As String)
Dim ii As Long
  Debug.Print Buffer
  'sends data in buffer on data connection;
  'data are sending in blocks of 1024 bytes
  ii = 1
  Do While Mid$(Buffer, ii, 1024) <> ""
    retf = send_data(Mid$(Buffer, ii, 1024), ID_User)
    If retf < 0 Then
      retf = WSAGetLastError()
      If retf = WSAEWOULDBLOCK Then
        'try again
      Else
        'error on send
        Exit Do
      End If
    Else
      ii = ii + 1024
    End If
    DoEvents
  Loop
  Buffer = ""
End Sub

Public Sub LIST_NLST(ByVal ID_User As Integer, ByVal Typ As String, ByVal Arg As String)
  Dim File_Name As String, name_ As String, exte_ As String
  Dim DummyS As String
  Dim SepN As Integer
  Dim Full_Name As String 'pathname & file name
  Dim PathName As String, Buffer As String

  If users(ID_User).State = Busy Then  '3
    If InStr(Arg, "-a -L") Then Arg = Left(Arg, (InStr(Arg, "-a -L") - 1))
    If Arg = "" Then
      'if LIST/NLST command has no argument the working directory is the current directory
      PathName = users(ID_User).cur_dir
    Else
      PathName = ChkPath(ID_User, Arg)
    End If
    If InStr(PathName, "*") Or InStr(PathName, "?") Then
      'the GettAttr command blows up with a * or ?
      'possibly because file doesn't exist?
      
      'the pathname indicates a file
      Full_Name = PathName
      File_Name = Dir$(Full_Name)
    ElseIf (GetAttr(PathName) And 16) <> 0 Then
      '--- the pathname indicates a directory
      'if radix then elides final backslash
      If Right$(PathName, 1) = "\" Then
        PathName = Left$(PathName, Len(PathName) - 1)
      End If
      File_Name = Dir$(PathName & "\*.*", 16)
      'rebuilds the full file name
      '(pathname & file name)
      Full_Name = PathName & "\" & File_Name
    Else
      'the pathname indicates a file
      Full_Name = PathName
      File_Name = Dir$(Full_Name)
    End If
    If Err.Number = 0 Then
      'opens data connection
      retf = open_data_connect(ID_User)
      Do
        If Not File_Name = "pagefile.sys" Then
        
        If File_Name = "." Or File_Name = ".." Then
          'parent directories
          DummyS = Format$(File_Name, "@@@@@@@@@@@@!") & " <DIR>"
        ElseIf InStr(Full_Name, "*") Or InStr(Full_Name, "?") Then
          'file
          SepN = InStr(File_Name, ".")
          If SepN <> 0 Then
            'name
            name_ = Left$(File_Name, SepN - 1)
            'extension
            exte_ = Mid$(File_Name, SepN + 1)
          Else
            name_ = File_Name
            exte_ = "   "
          End If
          DummyS = "-rwxr--r--   1 user    group  "
          If Typ = "LIST" Then
            DummyS = DummyS & Format$(FileLen(Full_Name), " @@@@@@@@@") _
             & " " & Format$(FileDateTime(Full_Name), " mmm dd hh:nn ") & File_Name
          ElseIf Typ = "NLST" Then
            'DummyS = Format$(FileLen(Full_Name), " @@@@@@@@@") & " " & File_Name
            DummyS = " " & File_Name & " "
          End If
        ElseIf GetAttr(Full_Name) = 16 Then
          'subdirectory
          SepN = InStr(File_Name, ".")
          If SepN <> 0 Then
            'name
            name_ = Left$(File_Name, SepN - 1)
            'extension
            exte_ = Mid$(File_Name, SepN + 1)
          Else
            name_ = File_Name
            exte_ = "   "
          End If
          DummyS = "drwxr-xr-x   1 user    group  "
          If Typ = "LIST" Then
            DummyS = DummyS & Format$(FileLen(Full_Name), " @@@@@@@@@") _
             & " " & Format$(FileDateTime(Full_Name), " mmm dd hh:nn ") & File_Name
          ElseIf Typ = "NLST" Then
            DummyS = Format$(FileLen(Full_Name), " @@@@@@@@@") & " "
          End If
        Else
          'file
          SepN = InStr(File_Name, ".")
          If SepN <> 0 Then
            'name
            name_ = Left$(File_Name, SepN - 1)
            'extension
            exte_ = Mid$(File_Name, SepN + 1)
          Else
            name_ = File_Name
            exte_ = "   "
          End If
          DummyS = "-rwxr--r--   1 user    group  "
          If Typ = "LIST" Then
            DummyS = DummyS & Format$(FileLen(Full_Name), " @@@@@@@@@") _
             & " " & Format$(FileDateTime(Full_Name), " mmm dd hh:nn ") & File_Name
          ElseIf Typ = "NLST" Then
            DummyS = File_Name
            'DummyS = Format$(FileLen(Full_Name), " @@@@@@@@@") & " " & File_Name
          End If
        End If
        Buffer = Buffer & DummyS & vbCrLf
        File_Name = Dir$
        If Left(File_Name, 1) = "p" Then
          File_Name = Dir$
        End If
      Debug.Print "File Name = " & File_Name
              If File_Name = "" Then Exit Do
              Full_Name = PathName & "\" & File_Name
      Else
        File_Name = Dir$
      End If
      Loop
      SendBuffer ID_User, Buffer
      'close data connection
      retf = send_reply("226 " & Typ & " command completed.", ID_User)
      retf = close_data_connect(ID_User)
    ElseIf (Err.Number > 51 And Err.Number < 77) Or (Err.Number > 707 And Err.Number < 732) Then
      retf = send_reply("450 " & Typ & " command not executed: " & Error$, ID_User)
      retf = close_data_connect(ID_User)
    Else
   '   frmFTP.StatusBar.Panels(1) = "Error " & Err.Number & " occurred."
      retf = close_data_connect(ID_User)
      retf = logoff(ID_User)
      'End
    End If
  ElseIf users(ID_User).State = Service_Commands Then '2
    retf = send_reply("425 Can't open data connection.", ID_User)
  Else
    retf = send_reply("530 User not logged in.", ID_User)
  End If
End Sub