ftp_lib.tcl

genesis 2000 v9.1软件下载

# Quote -- 
#
# The arguments specified are sent, verbatim, to the remote FTP server.     
#
# Arguments:
# 	arg1 arg2 ...
#
# Returns:
#  string sent back by the remote FTP server or null string if any error
#

proc Quote {args} {
variable ftp

	if ![info exists ftp(State)] {
		DisplayMsg "Not connected!" error
		return 0
	}

	set ftp(Cmd) $args

	set ftp(State) quote
	StateHandler

	# wait for synchronization
	set rc [WaitOrTimeout] 

	unset ftp(Cmd)

	if {$rc} {
		return $ftp(Quote)
	} else {
		return {}
	}
}

#############################################################################
#
# Abort -- 
#
# ABORT - Tells the server to abort the previous FTP service command and 
# any associated transfer of data. The control connection is not to be 
# closed by the server, but the data connection must be closed.
#
# NOTE: This procedure doesn't work properly. Thus the FTP::Abort command
# is no longer available!
#
# Arguments:
# None.
#
# Returns:
# 0 -			ERROR
# 1 - 			OK
#
# proc Abort {} {
# variable ftp
#
# }

#############################################################################
#
# Close -- 
#
# Terminates a ftp session and if file transfer is not in progress, the server
# closes the control connection.  If file transfer is in progress, the 
# connection will remain open for result response and the server will then
# close it. 
# (exported)
# 
# Arguments:
# None.
#
# Returns:
# 0 -			ERROR
# 1 - 			OK

proc Close {} {
variable ftp

	if ![info exists ftp(State)] {
		DisplayMsg "Not connected!" error
		return 0
	}

	set ftp(State) quit
	StateHandler

	# wait for synchronization
	WaitOrTimeout

	catch {close $ftp(CtrlSock)}
	catch {unset ftp}
}

#############################################################################
#
# Open --
#
# Starts the ftp session and sets up a ftp control connection.
# (exported)
# 
# Arguments:
# server - 		The ftp server hostname.
# user -		A string identifying the user. The user identification 
#			is that which is required by the server for access to 
#			its file system.  
# passwd -		A string specifying the user's password.
# options -		-blocksize size		writes "size" bytes at once
#						(default 4096)
#			-timeout seconds	if non-zero, sets up timeout to
#						occur after specified number of
#						seconds (default 120)
#			-progress proc		procedure name that handles callbacks
#						(no default)  
#			-mode mode		switch active or passive file transfer
#						(default active)
#			-port number		alternative port (default 21)
#  
# Returns:
# 0 -			Not logged in
# 1 - 			User logged in

proc Open {server user passwd {args ""}} {
variable ftp
upvar #0 finished state
	
	if [info exists ftp(State)] {
       		DisplayMsg "Mmh, another attempt to open a new connection? There is already a hot wire!" error
		return 0
	}

	# default NO DEBUG
	if {![info exists DEBUG]} {
		set DEBUG 0
	}

	# default NO VERBOSE
	if {![info exists VERBOSE]} {
		set VERBOSE 0
	}
	
	if {$DEBUG} {
		DisplayMsg "Starting new connection with: "
	}
	
	set ftp(User) 		$user
	set ftp(Passwd) 	$passwd
	set ftp(RemoteHost) 	$server
	set ftp(LocalHost) 	[info hostname]
	set ftp(DataPort) 	0
	set ftp(Type) 		{}
	set ftp(Error) 		{}
	set ftp(Progress) 	{}
	set ftp(Blocksize) 	4096	
	set ftp(Timeout) 	600	
	set ftp(Mode) 		active	
	set ftp(Port) 		21	

	set ftp(State) 		user
	
	# set state var
	set state(control) ""
	
	# Get and set possible options
	set options {-blocksize -timeout -mode -port -progress}
	foreach {option value} $args {
		if { [lsearch -exact $options $option] != "-1" } {
				if {$DEBUG} {
					DisplayMsg "  $option = $value"
				}
				regexp {^-(.?)(.*)$} $option all first rest
				set option "[string toupper $first]$rest"
				set ftp($option) $value
		} 
	}
	if { $DEBUG && ($args == "") } {
		DisplayMsg "  no option"
	}
    
	# No call of StateHandler is required at this time.
	# StateHandler at first time is called automatically
	# by a fileevent for the control channel.

	# Try to open a control connection
	if ![OpenControlConn] { return 0 }
	# waits for synchronization
	#   0 ... Not logged in
	#   1 ... User logged in
	if {[WaitOrTimeout]} {
		# default type is binary
		Type binary
		return 1
	} else {
		# close connection if not logged in
		Close
		return 0
	}
}

#############################################################################
#
# CopyNext --
#
# recursive background copy procedure for ascii/binary file I/O
# 
# Arguments:
# bytes - 		indicates how many bytes were written on $ftp(DestCI)

proc CopyNext {bytes} {
variable ftp 
upvar #0 finished state
    
	# summary bytes		
	incr ftp(Total) $bytes
        if { $ftp(ExpectedSize) != 0 } {
	   set bytes_to_read [expr $ftp(ExpectedSize) - $ftp(Total)]
	   if { $bytes_to_read > $ftp(Blocksize) } {
	      set bytes_to_read $ftp(Blocksize)
	   }
	} else {
	   set bytes_to_read  $ftp(Blocksize)
	}

        # callback for progress bar procedure
	if { ([info exists ftp(Progress)]) && ([info commands [lindex $ftp(Progress) 0]] != "") } { 
		eval $ftp(Progress) $ftp(Total)
	}
    
#        ftp_lib_debug_write_file \
          "CopyNext $ftp(SourceCI) $ftp(Total) [eof  $ftp(SourceCI)]"
        # setup new timeout handler
	after cancel $ftp(Wait)
	set ftp(Wait) [after [expr $ftp(Timeout) * 1000] [namespace current]::Timeout]

        if { [eof $ftp(SourceCI)] || $bytes_to_read==0 }  {

		# Close channels
		close $ftp(DestCI)
		close $ftp(SourceCI)
		unset state(data)
		DisplayMsg "D: Port closed"
		
	} else {
	        upvar #0 closed closed
#                ftp_lib_debug_write_file \
		   "fcopy is launched for $bytes_to_read bytes"
		fcopy $ftp(SourceCI) $ftp(DestCI) -command FTP::CopyNext -size $bytes_to_read
	}
	if { [string length $ftp(ReadCallback)] > 0 } {
	   $ftp(ReadCallback) $ftp(Total)
	}	
}

proc ftp_lib_debug_write_file { STRING } {
   set PATH "/tmp/ftp_lib.log"
   if { ! [catch { open $PATH {WRONLY CREAT} 0777 } FP] } {
      seek $FP 0 end
      puts $FP $STRING
      close $FP
   } else {
      puts "failed opening file"
   }
}

#############################################################################
#
# HandleData --
#
# Handles ascii/binary data transfer for Put and Get 
# 
# Arguments:
# sock - 		socket name (data channel)

proc HandleData {sock} {
variable ftp 
	# Turn off any fileevent handlers
	fileevent $sock writable {}		
	fileevent $sock readable {}

	# create local file for FTP::Get 
	if [regexp "^get" $ftp(State)] {
		set rc [catch {set ftp(DestCI) [open $ftp(LocalFilename) w]} msg]
		if { $rc != 0 } {
			DisplayMsg "$msg" error
			return 0
		}
		if { $ftp(Type) == "ascii" } {
			fconfigure $ftp(DestCI) -buffering line -blocking 1 
		} else {
			fconfigure $ftp(DestCI) -buffering line -translation binary -blocking 1
		}
	}	

	# append local file for FTP::Reget 
	if [regexp "^reget" $ftp(State)] {
		set rc [catch {set ftp(DestCI) [open $ftp(LocalFilename) a]} msg]
		if { $rc != 0 } {
			DisplayMsg "$msg" error
			return 0
		}
		if { $ftp(Type) == "ascii" } {
			fconfigure $ftp(DestCI) -buffering line -blocking 1
		} else {
			fconfigure $ftp(DestCI) -buffering line -translation binary -blocking 1
		}
	}	

	# perform fcopy	
	set ftp(Total) 0
	set ftp(Start_Time) [clock seconds]
	fcopy $ftp(SourceCI) $ftp(DestCI) -command [namespace current]::CopyNext -size $ftp(Blocksize)
	if { [string length $ftp(ReadCallback)] > 0 } {
	   $ftp(ReadCallback) $ftp(Total)
	}
}

#############################################################################
#
# HandleList --
#
# Handles ascii data transfer for list commands
# 
# Arguments:
# sock - 		socket name (data channel)

proc HandleList {sock} {
variable ftp 
variable DEBUG 
variable VERBOSE 
upvar #0 finished state

	if ![eof $sock] {
		set buffer [read $sock]
		if { $buffer != "" } {
			set ftp(List) [append ftp(List) $buffer]
		}	
	} else {
		close $sock
   		unset state(data)
		if {$VERBOSE} {
			DisplayMsg "D: Port closed" data
		}
	} 
}

############################################################################
#
# CloseDataConn -- 
#
# Closes all sockets and files used by the data conection
#
# Arguments:
# None.
#
# Returns:
# None.
#
proc CloseDataConn {} {
variable ftp

	catch {after cancel $ftp(Wait)}
	catch {fileevent $ftp(DataSock) readable {}}
	catch {close $ftp(DataSock); unset ftp(DataSock)}
	catch {close $ftp(DestCI); unset ftp(DestCI)} 
	catch {close $ftp(SourceCI); unset ftp(SourceCI)}
	catch {close $ftp(DummySock); unset ftp(DummySock)}
}

#############################################################################
#
# InitDataConn --
#
# Configures new data channel for connection to ftp server 
# ATTENTION! The new data channel "sock" is not the same as the 
# server channel "ftp(DataSock)".
# 
# Arguments:
# sock -		the name of the new channel
# addr -		the address, in network address notation, 
#			of the client's host,
# port -		the client's port number

proc InitDataConn {sock addr port} {
variable ftp
variable VERBOSE
upvar #0 finished state

	# If the new channel is accepted, the dummy channel will be closed
	catch {close $ftp(DummySock); unset ftp(DummySock)}

	set state(data) 0

	# Configure translation mode
	if { $ftp(Type) == "ascii" } {
		fconfigure $sock -buffering line 
#		fconfigure $sock -buffering line -blocking 1
	} else {
		fconfigure $sock -buffering line -translation binary 
#		fconfigure $sock -buffering line -translation binary -blocking 1
	}

	# assign fileevent handlers, source and destination CI (Channel Identifier)
	switch -regexp $ftp(State) {

		list {
			  fileevent $sock readable [list [namespace current]::HandleList $sock]
			  set ftp(SourceCI) $sock		  
			}

		get	{
			  fileevent $sock readable [list [namespace current]::HandleData $sock]
			  set ftp(SourceCI) $sock			  
			}

		append  -
		
		put {
			  fileevent $sock writable [list [namespace current]::HandleData $sock]
			  set ftp(DestCI) $sock			  
			}
	}

	if {$VERBOSE} {
		DisplayMsg "D: Connection from $addr:$port" data
	}
}

#############################################################################
#
# OpenActiveConn --
#
# Opens a ftp data connection
# 
# Arguments:
# None.
# 
# Returns:
# 0 -			no connection
# 1 - 			connection established

proc OpenActiveConn {} {
variable ftp
variable VERBOSE

	# Port address 0 is a dummy used to give the server the responsibility 
	# of getting free new port addresses for every data transfer.
	set rc [catch {set ftp(DummySock) [socket -server [namespace current]::InitDataConn 0]} msg]
	if { $rc != 0 } {
       		DisplayMsg "$msg" error
       		return 0
	}

	# get a new local port address for data transfer and convert it to a format
	# which is useable by the PORT command
	set p [lindex [fconfigure $ftp(DummySock) -sockname] 2]
	if {$VERBOSE} {
		DisplayMsg "D: Port is $p" data
	}
	set ftp(DataPort) "[expr "$p / 256"],[expr "$p % 256"]"

	return 1
}

#############################################################################
#
# OpenPassiveConn --
#
# Opens a ftp data connection
# 
# Arguments:
# buffer - returned line from server control connection 
# 
# Returns:
# 0 -			no connection
# 1 - 			connection established

proc OpenPassiveConn {buffer} {
variable ftp

	if {[regexp {([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)} $buffer all a1 a2 a3 a4 p1 p2]} {
		set ftp(LocalAddr) "$a1.$a2.$a3.$a4"
		set ftp(DataPort) "[expr $p1 * 256 + $p2]"

		# establish data connection for passive mode
	 	set rc [catch {set ftp(DataSock) [socket $ftp(LocalAddr) $ftp(DataPort)]} msg]
		if { $rc != 0 } {
			DisplayMsg "$msg" error
			return 0
		}

		InitDataConn $ftp(DataSock) $ftp(LocalAddr) $ftp(DataPort)			
		DisplayMsg $ftp(DataSock) 
		DisplayMsg $ftp(LocalAddr) 
		DisplayMsg $ftp(DataPort)
	        DisplayMsg "Passive"
	        return 1
	} else {
		return 0
	}
}
 
#############################################################################
#
# OpenControlConn --
#
# Opens a ftp control connection
# 
# Arguments:
# None.
# 
# Returns:
# 0 -			no connection
# 1 - 			connection established

proc OpenControlConn {} {
variable VERBOSE
variable DEBUG    
variable ftp
	# open a control channel
        set rc [catch {set ftp(CtrlSock) [socket $ftp(RemoteHost) $ftp(Port)]} msg]
	if { $rc != 0 } {
		if {$VERBOSE} {
       			DisplayMsg "C: No connection to server!" error
		}
		if {$DEBUG} {
			DisplayMsg "[list $msg]" error
		}
       		unset ftp(State)
       		return 0
	}
	# configure control channel
	fconfigure $ftp(CtrlSock) -buffering line -blocking 1 -translation {auto crlf}
        fileevent $ftp(CtrlSock) readable [list [namespace current]::StateHandler $ftp(CtrlSock)]
	
	# prepare local ip address for PORT command (convert pointed format to comma format)
	set ftp(LocalAddr) [lindex [fconfigure $ftp(CtrlSock) -sockname] 0]
	regsub -all "\[.\]" $ftp(LocalAddr) "," ftp(LocalAddr) 

	# report ready message
	set peer [fconfigure $ftp(CtrlSock) -peername]
	if {$VERBOSE} {
		DisplayMsg "C: Connection from [lindex $peer 0]:[lindex $peer 2]" control
	}
	
	return 1

}

# added TkCon support
# TkCon is (c) 1995-1999 Jeffrey Hobbs, http://www.purl.org/net/hobbs/tcl/script/tkcon/
# started with: tkcon -load FTP
if { [uplevel "#0" {info commands tkcon}] == "tkcon" } {

	# new FTP::List proc makes the output more readable
	proc __ftp_ls {args} {
		foreach i [::FTP::List_org $args] {
			puts $i
		}
	}

	# rename the original FTP::List procedure
	rename ::FTP::List ::FTP::List_org

	alias ::FTP::List	::FTP::__ftp_ls
	alias bye		catch {::FTP::Close; exit}	

	set ::FTP::VERBOSE 1
	set ::FTP::DEBUG 0
}


# not forgotten close-brace (end of namespace)

}