#!/bin/sh
# -*- tcl -*-
# The next line is executed by /bin/sh, but not tcl \
exec tclsh "$0" ${1+"$@"}

package require Expect

# rftp - ftp a directory hierarchy (i.e. recursive ftp)
# Version 2.10
# Don Libes, NIST
exp_version -exit 5.0

# rftp 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.

# rftp 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.

# ~/.rftprc is sourced after the user has logged in to the remote site
# and other ftp commands may be sent at that time.  .rftprc may also be
# used to override the following rftp 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###############################

match_max -d 100000		;# max size of a directory listing

# 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
	return [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

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

    if {$current_type != $new_type} {
	settype $new_type
    }

    set timeout $file_timeout
    send "put $name\r"
    expect timeout {
	send_user "ftp 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

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

    if {$current_type != $new_type} {
	settype $new_type
    }

    set timeout $file_timeout
    send "get $name\r"
    expect timeout {
	send_user "ftp 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
    } -re "(257|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
    } -re "2(5|0)0.*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
    } -re "2(5|0)0.*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*$name*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
    } -re "2(5|0)0.*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
    } -re "2(5|0)0.*ftp>.*"

	return 1
}

proc putentry {name type} {
    switch -- $type d {
	# directory
	if {$name=="." || $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} {
    switch -- $type d {
	# directory
	if {$name=="." || $name==".."} return
	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 "!/bin/ls -alg\r"
    expect timeout {
	send_user "failed to get directory listing\n"
	return
    } "ftp>*"

    set buf $expect_out(buffer)

    while {1} {
	# if end of listing, succeeded!
	if 0==[regexp "(\[^\n]*)\n(.*)" $buf dummy line buf] return

	set token [lindex $line 0]
	switch -- $token !/bin/ls {
	    # original command
	} total {
	    # directory header
	} . {
	    # unreadable
	} default {
	    # either file or directory
	    set name [getname $line]
	    set type [string index $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)

    while {1} {
	regexp "(\[^\n]*)\n(.*)" $buf dummy line buf

	set token [lindex $line 0]
	switch -- $token dir {
	    # 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 [string index $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 ~/.rftprc]} {source ~/.rftprc}
set first_time 1

if {$argc>1} {
    send_user "usage: rftp [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 {$argc==0} {spawn ftp} else {spawn ftp $argv}
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
}