Chip 1998 April/ChipCD_498.iso/software/ftp/quickftp/quickft1.bas

BASIC Source File | 1996-01-30 | 20.4 KB | 738 lines

'
' SocketWrench Visual Basic Module
'
' This module contains the constants used with the SocketWrench
' Windows Sockets custom control.
'

' global reply buffer

Global ctldata As String



'
' Socket actions
'
Global Const SOCKET_OPEN = 1
Global Const SOCKET_CONNECT = 2
Global Const SOCKET_LISTEN = 3
Global Const SOCKET_ACCEPT = 4
Global Const SOCKET_CANCEL = 5
Global Const SOCKET_FLUSH = 6
Global Const SOCKET_CLOSE = 7
Global Const SOCKET_ABORT = 8

'
' Socket states
'
Global Const SOCKET_NONE = 0
Global Const SOCKET_IDLE = 1
Global Const SOCKET_LISTENING = 2
Global Const SOCKET_CONNECTING = 3
Global Const SOCKET_ACCEPTING = 4
Global Const SOCKET_RECEIVING = 5
Global Const SOCKET_SENDING = 6
Global Const SOCKET_CLOSING = 7

'
' Address families
'
Global Const AF_UNSPEC = 0
Global Const AF_UNIX = 1
Global Const AF_INET = 2

'
' Socket types
'
Global Const SOCK_STREAM = 1
Global Const SOCK_DGRAM = 2
Global Const SOCK_RAW = 3
Global Const SOCK_RDM = 4
Global Const SOCK_SEQPACKET = 5

'
' Protocol types
'
Global Const IPPROTO_IP = 0
Global Const IPPROTO_ICMP = 1
Global Const IPPROTO_GGP = 2
Global Const IPPROTO_TCP = 6
Global Const IPPROTO_PUP = 12
Global Const IPPROTO_UDP = 17
Global Const IPPROTO_IDP = 22
Global Const IPPROTO_ND = 77
Global Const IPPROTO_RAW = 255
Global Const IPPROTO_MAX = 256

'
' Common ports
'
Global Const IPPORT_ANY = 0
Global Const IPPORT_ECHO = 7
Global Const IPPORT_DISCARD = 9
Global Const IPPORT_SYSTAT = 11
Global Const IPPORT_DAYTIME = 13
Global Const IPPORT_NETSTAT = 15
Global Const IPPORT_FTP = 21
Global Const IPPORT_TELNET = 23
Global Const IPPORT_SMTP = 25
Global Const IPPORT_TIMESERVER = 37
Global Const IPPORT_NameSERVER = 42
Global Const IPPORT_WHOIS = 43
Global Const IPPORT_MTP = 57
Global Const IPPORT_FINGER = 79
Global Const IPPORT_TFTP = 69
Global Const IPPORT_RESERVED = 1024
Global Const IPPORT_USERRESERVED = 5000

'
' Network addresses
'
Global Const INADDR_ANY = "0.0.0.0"
Global Const INADDR_LOOPBACK = "127.0.0.1"
Global Const INADDR_NONE = "255.255.255.255"

'
' Shutdown values
'
Global Const SOCKET_READ = 0
Global Const SOCKET_WRITE = 1
Global Const SOCKET_READWRITE = 2

'
' Error response values
'
Global Const SOCKET_ERRIGNORE = 0
Global Const SOCKET_ERRDISPLAY = 1

'
' Socket errors
'
Global Const WSABASEERR = 24000
Global Const WSAEINTR = 24004
Global Const WSAEBADF = 24009
Global Const WSAEACCES = 24013
Global Const WSAEFAULT = 24014
Global Const WSAEINVAL = 24022
Global Const WSAEMFILE = 24024
Global Const WSAEWOULDBLOCK = 24035
Global Const WSAEINPROGRESS = 24036
Global Const WSAEALREADY = 24037
Global Const WSAENOTSOCK = 24038
Global Const WSAEDESTADDRREQ = 24039
Global Const WSAEMSGSIZE = 24040
Global Const WSAEPROTOTYPE = 24041
Global Const WSAENOPROTOOPT = 24042
Global Const WSAEPROTONOSUPPORT = 24043
Global Const WSAESOCKTNOSUPPORT = 24044
Global Const WSAEOPNOTSUPP = 24045
Global Const WSAEPFNOSUPPORT = 24046
Global Const WSAEAFNOSUPPORT = 24047
Global Const WSAEADDRINUSE = 24048
Global Const WSAEADDRNOTAVAIL = 24049
Global Const WSAENETDOWN = 24050
Global Const WSAENETUNREACH = 24051
Global Const WSAENETRESET = 24052
Global Const WSAECONNABORTED = 24053
Global Const WSAECONNRESET = 24054
Global Const WSAENOBUFS = 24055
Global Const WSAEISCONN = 24056
Global Const WSAENOTCONN = 24057
Global Const WSAESHUTDOWN = 24058
Global Const WSAETOOMANYREFS = 24059
Global Const WSAETIMEDOUT = 24060
Global Const WSAECONNREFUSED = 24061
Global Const WSAELOOP = 24062
Global Const WSAENAMETOOLONG = 24063
Global Const WSAEHOSTDOWN = 24064
Global Const WSAEHOSTUNREACH = 24065
Global Const WSAENOTEMPTY = 24066
Global Const WSAEPROCLIM = 24067
Global Const WSAEUSERS = 24068
Global Const WSAEDQUOT = 24069
Global Const WSAESTALE = 24070
Global Const WSAEREMOTE = 24071
Global Const WSASYSNOTREADY = 24091
Global Const WSAVERNOTSUPPORTED = 24092
Global Const WSANOTINITIALISED = 24093
Global Const WSAHOST_NOT_FOUND = 25001
Global Const WSATRY_AGAIN = 25002
Global Const WSANO_RECOVERY = 25003
Global Const WSANO_DATA = 25004
Global Const WSANO_ADDRESS = 25004

Option Explicit

Function FTPcommand (commnd As String, controlsocket As Control, message As Label) As Integer
'__
'__ GLOBAL FTPcommand
'__
'__   parameter commnd As String
'__   parameter controlsocket As Control
'__   parameter message As Label
'__   called by GLOBAL FTPGetDirectory
'__   called by GLOBAL FTPGetDirList
'__   called by GLOBAL FTPGetFile
'__   called by GLOBAL FTPListen
'__   called by GLOBAL FTPLogin
'__   called by GLOBAL FTPPutFile
'__   called by GLOBAL FTPSetDirectory
'__   called by FTP_form SendFTPCOMMAND
'__   calls     GLOBAL FTPResult
'__
    Dim cmd
    Dim reply
    cmd = commnd
    On Error Resume Next
    While controlsocket.IsReadable
      reply = FTPResult(controlsocket, message)
    Wend
    If Left(cmd, 4) <> "PASS" Then message = "> " & cmd
    ctldata = cmd
    ctldata = ctldata & Chr$(13) & Chr$(10)
    controlsocket.SendLen = Len(ctldata)
    controlsocket.SendData = ctldata

    If Err <> 0 Then
        FTPcommand = False
    Else
        FTPcommand = True
    End If

End Function


Function FTPConnect (HostName As String, controlsocket As Control, message As Label)
'__
'__ GLOBAL FTPConnect
'__
'__   parameter HostName As String
'__   parameter controlsocket As Control
'__   parameter message As Label
'__   called by FTP_form DoConnectOnly
'__   calls     GLOBAL FTPResult
'__
    Dim reply As Integer
    Dim Errmess
    On Error GoTo ConnectError
    ctldata = ""
    Errmess = "Connect Error: "
    FTPConnect = False
    If HostName = "" Then Exit Function
    controlsocket.AddressFamily = AF_INET
    controlsocket.Protocol = IPPROTO_IP
    controlsocket.Type = SOCK_STREAM
    Errmess = "Error in Host Name " & HostName
    controlsocket.HostName = HostName
    controlsocket.RemotePort = IPPORT_FTP
    Errmess = "Connect Error: "
    controlsocket.Binary = False
    controlsocket.BufferSize = 1024
    controlsocket.Blocking = True

    On Error Resume Next
    Err = 0
    controlsocket.Action = SOCKET_CONNECT
    If Err Then
        MsgBox Error$
        Exit Function
    End If

      reply = FTPResult(controlsocket, message)

      If reply = 220 Then
        FTPConnect = True
      Else
        controlsocket.Action = SOCKET_CLOSE
      End If
    Exit Function
ConnectError:
    MsgBox Errmess, 64
    ctldata = Errmess
    Exit Function
End Function


Sub FTPDisconnect (controlsocket As Control)
'__
'__ GLOBAL FTPDisconnect
'__
'__   parameter controlsocket As Control
'__   called by FTP_form DoDisconnect
'__
        controlsocket.Action = SOCKET_CLOSE
End Sub


Sub FTPGetDirectory (controlsocket As Control, message As Label)
'__
'__ GLOBAL FTPGetDirectory
'__
'__   parameter controlsocket As Control
'__   parameter message As Label
'__   called by GLOBAL FTPSetDirectory
'__   called by FTP_form DoConnFTPDisc
'__   calls     GLOBAL FTPcommand
'__   calls     GLOBAL FTPResult
'__

    If Not FTPcommand("PWD", controlsocket, message) Then Exit Sub
    If FTPResult(controlsocket, message) <> 257 Then Exit Sub
    ctldata = Mid$(ctldata, 2, InStr(ctldata, " ") - 3)
End Sub


Function FTPGetDirList (controlsocket As Control, listendatasocket As Control, message As Label)
'__
'__ GLOBAL FTPGetDirList
'__
'__   parameter controlsocket As Control
'__   parameter listendatasocket As Control
'__   parameter message As Label
'__   called by FTP_form Do_the_dirlist
'__   calls     GLOBAL FTPcommand
'__   calls     GLOBAL FTPListen
'__   calls     GLOBAL FTPResult
'__
    Dim buffer As String
    Dim result As Integer
    Dim ifile As Integer
    FTPGetDirList = False
    If Not FTPListen(controlsocket, listendatasocket, message) Then Exit Function
    result = FTPcommand("TYPE A", controlsocket, message)
    If result Then result = FTPResult(controlsocket, message)
    result = FTPcommand("NLST", controlsocket, message)
    If Not result Then Exit Function
    result = FTPResult(controlsocket, message)
    While controlsocket.IsReadable
      result = FTPResult(controlsocket, message)
    Wend
    If result > 299 Then
        listendatasocket.Action = SOCKET_CLOSE
        Exit Function
    End If

    listendatasocket.Action = SOCKET_ACCEPT
    On Error Resume Next
    Kill Dir_File
    ifile = FreeFile
    Err = 0
    Open Dir_File For Binary As #ifile
    If Err Then
        Close ifile
        MsgBox Error$
        listendatasocket.Action = SOCKET_CLOSE
        Exit Function
    End If

    Do
        listendatasocket.RecvLen = 1024
        Err = 0
        buffer = listendatasocket.RecvData
        If Err Then
            MsgBox Error$
            Exit Do
        End If
        If listendatasocket.RecvLen = 0 Then Exit Do
        Put #ifile, , buffer
        DoEvents
    Loop

    Close #ifile
    listendatasocket.Action = SOCKET_CLOSE
    If controlsocket.IsReadable Then result = FTPResult(controlsocket, message)
    FTPGetDirList = True
End Function


Function FTPGetFile (RemoteFile As String, LocalFile As String, controlsocket As Control, listendatasocket As Control, message As Label)
'__
'__ GLOBAL FTPGetFile
'__
'__   parameter RemoteFile As String
'__   parameter LocalFile As String
'__   parameter controlsocket As Control
'__   parameter listendatasocket As Control
'__   parameter message As Label
'__   called by FTP_form getfilenow
'__   calls     GLOBAL FTPcommand
'__   calls     GLOBAL FTPListen
'__   calls     GLOBAL FTPResult
'__
    Dim buffer As String
    Dim result As Integer
    Dim unit As Integer
    Dim ti As Double
    FTPGetFile = False
    transferaborted = False

    If RemoteFile = "" Or LocalFile = "" Then Exit Function
    On Error Resume Next
    unit = FreeFile
    ''was a bug!!! missing:
    Kill LocalFile
    Err = 0
    Open LocalFile For Binary As unit
    If Err Then
        ctldata = Error$
        Close unit
        Exit Function
    End If

    If Not FTPListen(controlsocket, listendatasocket, message) Then Close unit: Exit Function
    If Not FTPcommand("RETR " & RemoteFile, controlsocket, message) Then Close unit: Exit Function

    result = FTPResult(controlsocket, message)
    If result \ 100 <> 1 Then
        listendatasocket.Action = SOCKET_CLOSE
        Close unit
        Exit Function
    End If

    listendatasocket.Action = SOCKET_ACCEPT


    FTPGetFile = True

    Do
        listendatasocket.RecvLen = listendatasocket.BufferSize
        Err = 0
        buffer = listendatasocket.RecvData
        If Err Then
            FTPGetFile = False
            MsgBox Error$
            Exit Do
        End If
        If transferaborted Then
            FTPGetFile = False
            MsgBox "File Transfer Aborted", 32
            message = "File Transfer Aborted"
            Exit Do
        End If
        If listendatasocket.RecvLen = 0 Then Exit Do
        Put unit, , buffer
        message = Seek(1)
        DoEvents
    Loop

    Close unit
    listendatasocket.Action = SOCKET_CLOSE
    result = FTPResult(controlsocket, message)
End Function


Function FTPListen (controlsocket As Control, listendatasocket As Control, message As Label)
'__
'__ GLOBAL FTPListen
'__
'__   parameter controlsocket As Control
'__   parameter listendatasocket As Control
'__   parameter message As Label
'__   called by GLOBAL FTPGetDirList
'__   called by GLOBAL FTPGetFile
'__   called by GLOBAL FTPPutFile
'__   calls     GLOBAL FTPcommand
'__   calls     GLOBAL FTPResult
'__
    Dim Port As Integer, HexPort As String, Address As String
    Dim reply As Integer
    Dim i As Integer, P As Integer

    FTPListen = False

    listendatasocket.AddressFamily = AF_INET
    listendatasocket.Binary = True
    listendatasocket.Blocking = True
    listendatasocket.BufferSize = 1024
    listendatasocket.HostAddress = INADDR_ANY
    listendatasocket.LocalPort = IPPORT_ANY
'    listendatasocket.Protocol = IPPROTO_TCP
    listendatasocket.Protocol = IPPROTO_IP
    listendatasocket.Timeout = 0
    listendatasocket.Type = SOCK_STREAM
    listendatasocket.Action = SOCKET_LISTEN

    '
    ' Construct a PORT command string that consists of the
    ' local IP address and port number broken down into six
    ' bytes seperated by commas
    '
    Port = listendatasocket.LocalPort
    Address = listendatasocket.LocalAddress

    '
    ' The IP address part is easy because it's already in
    ' dot notation; just substitute commas for the dots
    '
    For i = 1 To 3
        P = InStr(Address, ".")
        If P <> 0 Then Mid$(Address$, P, 1) = ","
    Next i

    '
    ' Split the local port number into high and low bytes by
    ' converting it to hex, pulling it apart, and then converting
    ' the pieces back to decimal
    '
    HexPort = Hex$(Port)
    If Len(HexPort) = 3 Then HexPort = "0" + HexPort
    ctldata = "PORT " & Address & "," & (Val("&h" + Left$(HexPort, 2))) & "," & (Port And &HFF)

    '
    ' Send the PORT command to the server so that it knows
    ' where we are
    '
    If Not FTPcommand(ctldata, controlsocket, message) Then GoTo OpenFailed
    If FTPResult(controlsocket, message) <> 200 Then GoTo OpenFailed

    '
    ' Select the file type for transfer
    '
    If TransType = Asc("I") Then
        ctldata = "TYPE I"
    Else
        ctldata = "TYPE A"
    End If

    If Not FTPcommand(ctldata, controlsocket, message) Then GoTo OpenFailed
    If FTPResult(controlsocket, message) \ 100 <> 2 Then GoTo OpenFailed

    FTPListen = True
    Exit Function

OpenFailed:
    If listendatasocket.Listening Then listendatasocket.Action = SOCKET_CLOSE
    Exit Function
End Function


Function FTPLogin (Username As String, Password As String, controlsocket As Control, listendatasocket As Control, message As Label) As Integer
'__
'__ GLOBAL FTPLogin
'__
'__   parameter Username As String
'__   parameter Password As String
'__   parameter controlsocket As Control
'__   parameter listendatasocket As Control
'__   parameter message As Label
'__   called by FTP_form DoConnectOnly
'__   calls     GLOBAL FTPcommand
'__   calls     GLOBAL FTPResult
'__
    Dim reply As Integer
    Dim Counter As Integer

    FTPLogin = False
    If controlsocket.IsReadable Then
        reply = FTPResult(controlsocket, message)
    End If

    While reply \ 100 <> 2 And controlsocket.IsReadable
        reply = FTPResult(controlsocket, message)
    Wend

    ctldata = "USER " & Username
    If Not FTPcommand(ctldata, controlsocket, message) Then Exit Function
    reply = FTPResult(controlsocket, message)

    If reply = 331 Then
        ctldata = "PASS " & Password
        If Not FTPcommand(ctldata, controlsocket, message) Then Exit Function
        reply = FTPResult(controlsocket, message)
    End If

    While reply \ 100 <> 2 And controlsocket.IsReadable
        reply = FTPResult(controlsocket, message)
    Wend

    If reply = 230 Then
        FTPLogin = True
    Else
        MsgBox "Invalid user name or password"
    End If

End Function


Function FTPPutFile (LocalFile As String, RemoteFile As String, controlsocket As Control, listendatasocket As Control, message As Label)
'__
'__ GLOBAL FTPPutFile
'__
'__   parameter LocalFile As String
'__   parameter RemoteFile As String
'__   parameter controlsocket As Control
'__   parameter listendatasocket As Control
'__   parameter message As Label
'__   called by FTP_form putfilenow
'__   calls     GLOBAL FTPcommand
'__   calls     GLOBAL FTPListen
'__   calls     GLOBAL FTPResult
'__
    Dim buffer As String
    Dim result As Integer, size As Long
    Dim unit As Integer
    Dim i As Integer
    Dim ti As Double
    On Error Resume Next
    Err = 0
    ctldata = "Unknown Error"
    FTPPutFile = False
    transferaborted = False

    If RemoteFile = "" Or LocalFile = "" Then Exit Function
    unit = FreeFile
    Open LocalFile For Binary As unit

    If Err Then
        'got an error...on file open...don't proceed
        ctldata = Error$
        Close unit
        Exit Function
    End If

    If Not FTPListen(controlsocket, listendatasocket, message) Then Close unit: Exit Function
    If Not FTPcommand("STOR " & RemoteFile, controlsocket, message) Then Close unit: Exit Function

    If FTPResult(controlsocket, message) \ 100 <> 1 Then
        listendatasocket.Action = SOCKET_ABORT
        Close unit
        Exit Function
    End If

    Err = 0
    listendatasocket.Action = SOCKET_ACCEPT

    size = FileLen(LocalFile)
'    If size < listendatasocket.buffersize Then
'            listendatasocket.SendLen = size
'    Else
'            listendatasocket.SendLen = listendatasocket.buffersize
'    End If
    buffer = Space(listendatasocket.BufferSize)

    If Err Then
        listendatasocket.Action = SOCKET_CLOSE
        ctldata = Error$
        Close unit
        Exit Function
    End If

    FTPPutFile = True
    Do
        Get unit, , buffer
        If size < Len(buffer) Then
            listendatasocket.SendLen = size
            listendatasocket.SendData = Left(buffer, size)
            size = 0
        Else
             listendatasocket.SendLen = Len(buffer)
             listendatasocket.SendData = buffer
             size = size - Len(buffer)
        End If
        Debug.Print listendatasocket.SendLen
        While Not listendatasocket.IsWritable: DoEvents: Wend
        ti = Timer: While Timer - .1 < ti: DoEvents: Wend
        message = size
        If Err > 0 Then
            FTPPutFile = False
            MsgBox Error$
            Exit Do
        End If
        If transferaborted Then
            FTPPutFile = False
            MsgBox "File Transfer Aborted", 32
            Exit Do
        End If
        If size = 0 Then Exit Do
        For i = 1 To 200: DoEvents: Next
    Loop

    Close unit
    listendatasocket.Action = SOCKET_CLOSE
    result = FTPResult(controlsocket, message)
End Function


Function FTPResult (controlsocket As Control, message As Label) As Integer
'__
'__ GLOBAL FTPResult
'__
'__   parameter controlsocket As Control
'__   parameter message As Label
'__   called by GLOBAL FTPcommand
'__   called by GLOBAL FTPConnect
'__   called by GLOBAL FTPGetDirectory
'__   called by GLOBAL FTPGetDirList
'__   called by GLOBAL FTPGetFile
'__   called by GLOBAL FTPListen
'__   called by GLOBAL FTPLogin
'__   called by GLOBAL FTPPutFile
'__   called by GLOBAL FTPSetDirectory
'__   called by FTP_form SendFTPCOMMAND
'__
    Dim sockdata As String, reply As Integer
    Dim continued As Integer
    On Error Resume Next

  continued = 0
  Do

    DoEvents
    controlsocket.RecvLen = 255
    '
    '
    sockdata = ""

    sockdata = controlsocket.RecvData & "     " 'pad just in case
    message = "< " & sockdata

    reply = Val(Left$(sockdata, 3))
'    If Mid$(sockdata, 4, 1) = "-" Then
'        Do
'            controlsocket.RecvLen = 255
'            sockdata = controlsocket.RecvData
'            If Val(Left$(sockdata, 3)) = reply Then Exit Do
'            message = "<" & sockdata
'        Loop
'    End If
    ctldata = Right$(sockdata, Len(sockdata) - InStr(sockdata, " "))
    On Error Resume Next

    If Mid(sockdata, 4, 1) = " " Then
      If reply = continued Then continued = 0
    ElseIf Mid(sockdata, 4, 1) = "-" And continued = 0 Then
        '- is continuation character, first line only
        'keep going until RFC959 is satisfied:
        'same code with space
        continued = reply
    End If
    DoEvents
  Loop Until continued = 0
  FTPResult = reply
End Function


Sub FTPSetDirectory (dirname As String, controlsocket As Control, message As Label)
'__
'__ GLOBAL FTPSetDirectory
'__
'__   parameter dirname As String
'__   parameter controlsocket As Control
'__   parameter message As Label
'__   called by FTP_form DoConnFTPDisc
'__   called by FTP_form GoToDir
'__   calls     GLOBAL FTPcommand
'__   calls     GLOBAL FTPGetDirectory
'__   calls     GLOBAL FTPResult
'__
    Dim cmd As String
    If dirname = ".." Then cmd = "CDUP" Else cmd = "CWD " & dirname
    If Not FTPcommand(cmd, controlsocket, message) Then Exit Sub

    If FTPResult(controlsocket, message) <> 250 Then Exit Sub
    Call FTPGetDirectory(controlsocket, message)
End Sub