#!out -f

##############################################################################
# SFTP version 1.0   --   A GUI on top of ftp
#   Matthijs van Doorn  <thijs@cs.vu.nl>
#   based on Don Libes' "rftp" (part of the expect distribution)
#
# This is not a full featured program, but just an example to show how easy
# a GUI on top of a existing program can be writen with expect/Tk.
# The original ftp-output is shown in the xterm-window to show you how 'sftp'
# uses 'ftp'.

set BMPATH "/usr/prac/se/hush/include/bitmaps"

set file_timeout 3600		;# timeout (seconds) for retrieving files
set timeout 1000000		;# timeout (seconds) for other ftp dialogue

# 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 sftp (at least, not without changing the scanning and parsing).
##############################################################################

trap exit SIGINT		;# exit on ^C
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]]
	}
}


# get the file 'name' from the current directory
proc getfile {name} {
	global file_timeout

	set timeout $file_timeout

	# turn hash on so user can see progress in xterm window
	send_spawn "hash\r"
	expect "ftp>"

	# get the file
	send_spawn "get $name\r"
	expect timeout {
		send_user "ftp timed out in response to \"get $name\"\n"
		exit
	} "ftp>*"

	# turn hash off again to prevent #-s during directory listings
	send_spawn "hash\r"
	expect "ftp>"
}


# get the entry 'name' of type 'type'
proc getentry {name type} {
	case $type in \
	d {
		# directory
		gotodirectory $name
		filldirectorybox
	} - {
		# file
		getfile $name
	} l {
		# symlink, could be either file or directory
		# first assume it's a directory
		if [gotodirectory $name] {
			filldirectorybox
		} else {
			getfile $name
		}
	} default {
		send_user "can't figure out what $name is, skipping\n"
	}
}


# returns 1 if successful, 0 otherwise
proc gotodirectory {name} {
	send_spawn "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
	} -re "2(5|0)0.*ftp>.*"
	# some ftp's return 200, some return 250

	return 1
}


# fill the name and type listboxes
proc filldirectorybox {} {
	goto_sleep

	# send dir command
	send_spawn "dir\r"
	expect timeout {
		send_user "failed to get directory listing\n"
		wake_up
		return
	} "ftp>*"

	# get output
	set buf $expect_out(buffer)

	# delete old contents
	.top.namelist delete 0 end
	.top.typelist delete 0 end

	# insert parent directory
	.top.namelist insert 0 ".."
	.top.typelist insert 0 "d"

	# fill the listboxes line-by-line
	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!
			wake_up
			return
		} ftp>* {
			# next prompt, failed!
			wake_up
			return
		} . {
			# unreadable
		} default {
			# either file or directory
			set name [getname $line]
			set type [lindex [split $line ""] 0]
			.top.namelist insert end "$name"
			.top.typelist insert end "$type"
		}
	}
	wake_up
}


# init 
proc init {} {
	global argv env
	global login

	if [llength $argv]!=1 {
		send_user "usage: sftp <host>\n"
		exit
	}

	set user $env(USER)
	regexp {[^.]*.(.*)} "efsix.cs.vu.nl" total domain
	set login "$user@$domain"
}


# make cursor hour-glass
proc goto_sleep {} {
	global BMPATH

	.top.namelist config -cursor \
	    "@$BMPATH/hour_glass.bm $BMPATH/hour_glass_mask.bm black white"
	.top.typelist config -cursor \
	    "@$BMPATH/hour_glass.bm $BMPATH/hour_glass_mask.bm black white"
}


# normal cursor
proc wake_up {} {
	# global BMPATH

	.top.namelist config -cursor ""
	.top.typelist config -cursor ""
}


# process entry selindex
proc process {selindex} {
	getentry [.top.namelist get $selindex] [.top.typelist get $selindex]
}


# exit program
proc proc_exit {} {
	send_spawn "quit\r"
	exit
}


# goto root directory
proc proc_home {} {
	send_spawn "cd /\r"
	expect "ftp>"
	filldirectorybox
}


# get seleted file
proc proc_get {} {
	goto_sleep
	process [lindex [.top.namelist curselection] 0]
	wake_up
}


# used to scroll both listboxes when the scrollbar moves
proc scroll_both index {
	.top.namelist yview $index
	.top.typelist yview $index
}


# build the GUI
proc build_interface {} {
	frame .top 
	frame .bot

	button .bot.get   -text "Get"   -command {proc_get} -width 12
	button .bot.exit  -text "Exit"  -command {proc_exit} -width 12
	button .bot.home  -text "Home"  -command {proc_home} -width 12

	listbox .top.typelist -relief sunken -geometry 4x30
	listbox .top.namelist -relief sunken -geometry 80x30
	scrollbar .top.scrollbar -orient vertical -command {scroll_both}

	bind .top.namelist <Double-1> {proc_get}

	pack append .top .top.typelist {left} \
			 .top.namelist {right} \
			 .top.scrollbar {right expand filly}

	pack append .bot .bot.get {bottom left padx 10} \
			 .bot.home {left padx 10} \
			 .bot.exit {left padx 10}

	pack append . .top {top padx 20 pady 20} .bot {bottom padx 20 pady 20}
}


# login on sitename and see binary type
proc login_on_site {sitename} {
	global spawn_id
	global default_type
	global login
	global use_ncftp

	goto_sleep

	# startup ftp-process. Use -n to prevent auto-login (.netrc)
	spawn -noecho ftp {-n}
	expect "ftp>"

	send_spawn "open [lindex $sitename 0]\r"
	expect "ftp>"
	send_spawn "user anonymous\r"
	expect "Password"
	send_spawn "$login\r"
	expect "ftp>"
	send_spawn "bin\r"
	expect "ftp>"

	wake_up
}


# main
proc main {argv} {
	global spawn_id

	init
	send_user "Welcome to sftp!\n\n"
	build_interface
	login_on_site $argv

	filldirectorybox
}


##############################################################################
main $argv
