InfoMagic Source Code 1993 July/THE_SOURCE_CODE_CD_ROM.iso/languages/tcl/expect/scripts/riftp

Text File | 1992-12-29 | 9.0 KB | 359 lines

#!../expect -f
# riftp - ftp a directory hierarchy (i.e. recursive ftp)
# Based on Version 2.6 rftp, Don Libes, NIST
# Changes for rftp done by Mary Leisner <[e-mail]>

# riftp is much like ftp except that the command ~g copies everything in
# the remote current working directory to the local current working
# directory.  Similarly ~p copies in the reverse direction.  ~l just
# lists the remote directories.

# riftp takes an argument of the host to ftp to.  Username and password
# are prompted for.  Other ftp options can be set interactively at that
# time.  If your local ftp understands .netrc, that is also used.

# ~/.riftprc is sourced after the user has logged in to the remote site
# and other ftp commands may be sent at that time.  .riftprc may also be
# used to override the following riftp defaults.  The lines should use
# the same syntax as these:

set file_timeout 3600        ;# timeout (seconds) for retrieving files
set timeout 1000000        ;# timeout (seconds) for other ftp dialogue
set default_type binary        ;# default type, i.e., ascii, binary, tenex
set binary {}            ;# files matching are transferred as binary
set ascii {}            ;# as above, but as ascii
set tenex {}            ;# as above, but as tenex

# The values of binary, ascii and tenex should be a list of (Tcl) regular
# expressions.  For example, the following definitions would force files
# ending in *.Z and *.tar to be transferred as binaries and everything else
# as text.

# set default_type ascii
# set binary {*.Z *.tar}

# If you are on a UNIX machine, you can probably safely ignore all of this
# and transfer everything as "binary".

# The current implementation requires that the source host be able to
# provide directory listings in UNIX format.  Hence, you cannot copy
# from a VMS host (although you can copy to it).  In fact, there is no
# standard for the output that ftp produces, and thus, ftps that differ
# significantly from the ubiquitous UNIX implementation may not work
# with rftp (at least, not without changing the scanning and parsing).

####################end of documentation###############################

trap exit SIGINT        ;# exit on ^C
match_max -d 100000        ;# max size of a directory listing

# strip last character (a return) off the end of the line
proc strip_last_char {s} {
    set s [split $s ""]
    return [join [lrange $s 0 [expr [llength $s]-1]] ""]
}

# return name of file from one line of directory listing
proc getname {line} {
    # if it's a symbolic link, return local name
    set i [lsearch line "->"]
    if {-1==$i} {
         # not a sym link
         # return last token of line as name, and strip off newline at end
         return [strip_last_char [lindex $line [expr [llength $line]-1]]]
    } else {
         # sym link, return "a" of "a -> b"
         return [lindex $line [expr $i-1]]
    }
}

proc putfile {name} {
    global current_type default_type
    global binary ascii tenex
    global file_timeout

    case $name    $binary    {set new_type binary} \
            $ascii    {set new_type ascii} \
            $tenex    {set new_type tenex} \
            default    {set new_type $default_type}

    if 0!=[string compare $current_type $new_type] {
        settype $new_type
    }

    set timeout $file_timeout
    send "put $name\r"
    expect timeout {
        send_user "iftp timed out in response to \"put $name\"\n"
        exit
    } "*ftp>*"
}

proc getfile {name} {
    global current_type default_type
    global binary ascii tenex
    global file_timeout

    case $name    $binary    {set new_type binary} \
            $ascii    {set new_type ascii} \
            $tenex    {set new_type tenex} \
            default    {set new_type $default_type}

    if 0!=[string compare $current_type $new_type] {
        settype $new_type
    }

    set timeout $file_timeout
    send "get $name\r"
    expect timeout {
        send_user "iftp timed out in response to \"get $name\"\n"
        exit
    } "*ftp>*"
}

# returns 1 if successful, 0 otherwise
proc putdirectory {name} {
    send "mkdir $name\r"
    expect *550*denied*ftp>* {
        send_user "failed to make remote directory $name\n"
        return 0
    } timeout {
        send_user "timed out on make remote directory $name\n"
        return 0
    } {*257*ftp>* *550*exists*ftp>*}
    # 550 is returned if directory already exists

    send "cd $name\r"
    expect *550*ftp>* {
        send_user "failed to cd to remote directory $name\n"
        return 0
    } timeout {
        send_user "timed out on cd to remote directory $name\n"
        return 0
    } {*250*ftp>* *200*ftp>*}
    # some ftp's return 200, some return 250

    send "lcd $name\r"
    # hard to know what to look for, since my ftp doesn't return status
    # codes.  It is evidentally very locale-dependent.
    # So, assume success.
    expect "*ftp>*"
    putcurdirectory
    send "lcd ..\r"
    expect "*ftp>*"
    send "cd ..\r"
    expect timeout {
        send_user "failed to cd to remote directory ..\n"
        return 0
    } {*250*ftp>* *200*ftp>*}

    return 1
}

# returns 1 if successful, 0 otherwise
proc getdirectory {name transfer} {
    send "cd $name\r"
    # this can fail normally if it's a symbolic link, and we are just
    # experimenting
    expect *550*ftp>* {
        send_user "failed to cd to remote directory $name\n"
        return 0
    } timeout {
        send_user "timed out on cd to remote directory $name\n"
        return 0
    } {*250*ftp>* *200*ftp>*}
    # some ftp's return 200, some return 250

    if $transfer {
        send "!mkdir $name\r"
        expect "*denied*" return timeout return "*ftp>*"
        send "lcd $name\r"
        # hard to know what to look for, since my ftp doesn't return status
        # codes.  It is evidentally very locale-dependent.
        # So, assume success.
        expect "*ftp>*"
    }
    getcurdirectory $transfer
    if $transfer {
        send "lcd ..\r"
        expect "*ftp>*"
    }
    send "cd ..\r"
    expect timeout {
        send_user "failed to cd to remote directory ..\n"
        return 0
    } {*250*ftp>* *200*ftp>*}

    return 1
}

proc putentry {name type} {
    case $type in \
    d {
        # directory
        if {0==[string compare $name .]
         || 0==[string compare $name ..]} return
        putdirectory $name
    } - {
        # file
        putfile $name
    } l {
        # symlink, could be either file or directory
        # first assume it's a directory
        if [putdirectory $name] return
        putfile $name
    } default {
        send_user "can't figure out what $name is, skipping\n"
    }
}

proc getentry {name type transfer} {
    case $type in \
    d {
        # directory
        getdirectory $name $transfer
    } - {
        # file
        if !$transfer return
        getfile $name
    } l {
        # symlink, could be either file or directory
        # first assume it's a directory
        if [getdirectory $name $transfer] return
        if !$transfer return
        getfile $name
    } default {
        send_user "can't figure out what $name is, skipping\n"
    }
}

proc putcurdirectory {} {
    send "!ls -alg\r"
    expect timeout {
        send_user "failed to get directory listing\n"
        return
    } "*ftp>*"

    set buf $expect_out(buffer)

    for {} 1 {} {
        set split_buf [split $buf ""]

        # get a line from the response
        set i [string first "\n" $buf]
        # if end of listing, succeeded!
        if $i==-1 return
        set line [join [lrange $split_buf 0 $i] ""]
        set buf [join [lrange $split_buf [expr 1+$i] end] ""]

        set token [lindex $line 0]
        case $token in \
        !ls {
            # original command
        } total {
            # directory header
        } . {
            # unreadable
        } default {
            # either file or directory
            set name [getname $line]
            set type [lindex [split $line ""] 0]
            putentry $name $type
        }
    }
}


# look at result of "dir".  If transfer==1, get all files and directories
proc getcurdirectory {transfer} {
    send "dir\r"
    expect timeout {
        send_user "failed to get directory listing\n"
        return
    } "*ftp>*"

    set buf $expect_out(buffer)

    for {} 1 {} {
        set split_buf [split $buf ""]

        # get a line from the response
        set i [string first "\n" $buf]
        set line [join [lrange $split_buf 0 $i] ""]
        set buf [join [lrange $split_buf [expr 1+$i] end] ""]

        set token [lindex $line 0]
        case $token in \
        dir\r {
            # original command
        } 200 {
            # command successful
        } 150 {
            # opening data connection
        } total {
            # directory header
        } 226 {
            # transfer complete, succeeded!
            return
        } ftp> {
            # next prompt, failed!
            return
        } . {
            # unreadable
        } default {
            # either file or directory
            set name [getname $line]
            set type [lindex [split $line ""] 0]
            getentry $name $type $transfer
        }
    }
}

proc settype {t} {
    global current_type

    send "type $t\r"
    set current_type $t
    expect "*200*ftp>*"
}

proc final_msg {} {
    # write over the previous prompt with our message
    send_user "\rQuit ftp or cd to another directory and press ~g, ~p, or ~l\n"
    # and then reprompt
    send_user "ftp> "
}

if [file readable ~/.riftprc] {source ~/.riftprc}
set first_time 1

if [llength $argv]>2 {
    send_user "usage: riftp [host]
    exit
}

send_user "Once logged in, cd to the directory to be transferred and press:\n"
send_user "~p to put the current directory from the local to the remote host\n"
send_user "~g to get the current directory from the remote host to the local host\n"
send_user "~l to list the current directory from the remote host\n"

if [llength $argv]==1 {spawn iftp} else {spawn ftp [lindex $argv 1]}
interact -echo ~g {
        if $first_time {
            set first_time 0
            settype $default_type
        }
        getcurdirectory 1
        final_msg
} -echo ~p {
        if $first_time {
            set first_time 0
            settype $default_type
        }
        putcurdirectory
        final_msg
} -echo ~l {
        getcurdirectory 0
        final_msg
}