#!../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 <leisner@eso.mc.xerox.com>

# 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
}