Source code for the File Push Server. This application requires spynergy.tcl.


#######################################################
# PushServ.tcl -- A true server-push system for unattended Internet file distribution.
#  by Mike Doyle
#
#   This system requires that PushClnt.tcl be running on at least
#   one Internet-accessible machine. If files are pushed from
#   subdirectories, then those subdirectory names must pre-exist
#   on the client machine.
#
#  Copyright (c) 1997 Eolas Technologies Inc.
#  Freely modifiable/redistributable under the "Standard Tcl License"
#  See http://www.eolas.com/tcl/license.txt for details

#######################################
# file_add-- add a file to the push list
proc file_load {} {
    global _F _PUSH
	set _F(file) [loadsave 1]
    if {$_F(file) == ""} {return}
    if {![file readable $_F(file)]} {
        filepush_error "File \[$_F(file)\] is not readable."
        return
    }
.filepush.lists.files.filelist insert end $_F(file)
.filepush.lists.files.filelist yview end
set _PUSH($_F(file)~~time) ""
}


############################################
# Start the directory browser procs
#
proc loadsave {loadflag} {
	global loadsave _F 
	if {![info exists loadsave(pwd)]} {
		set loadsave(pwd) [pwd]
		set loadsave(filter) "*"
		set loadsave(file) ""
	}
	set loadsave(loadflag) $loadflag
	set loadsave(path) ""
	set loadsave(done) 0
	#- TOP LEVEL -----------------------------------------
	toplevel .loadsave  -background LightGray
	wm withdraw .loadsave
	if {$loadflag == "1"} {
		wm title .loadsave "Open File"
	} else {
		wm title .loadsave "Save File"
	}

	wm geometry .loadsave +[expr ([winfo screenwidth .]/2) - 173]+[expr ([winfo screenheight .]/2) - 148]
	set Toppos(.loadsave) 0
	set Topgeom(.loadsave) 1
	
	#------------------------------------------
	set Name .loadsave
	set Parent $Name
	
	#------------------------------------------
	set Name $Parent.f1
	frame $Name -background lightgray
	pack $Name -anchor nw -side top 

	#-------------disable this entry to prevent manual path entry outside of tree------------------
	set Name $Parent.f1.e3
	entry $Name  -background white -foreground black \
			-highlightbackground LightGray -width 35 \
			-textvariable loadsave(pwd) -state disabled
	pack $Name -side right -anchor nw -padx 5
	bind $Name  {loadsavegetentries}
   	bind $Name  {
		if [%W selection present] {
			%W delete sel.first sel.last
		} else {
			%W delete insert
		}
	}
    	#----------
	set Name $Parent.f1.l1
	label $Name  -background LightGray  -text "Directory: "
	pack $Name -side right -anchor nw

	#------------------------------------------
	set Name $Parent.f2
	frame $Name -background lightgray
	pack $Name -anchor nw -side top -fill x

	#------------------------------------------
	set Name $Parent.f2.e7
	entry $Name  -background white -foreground black \
			-highlightbackground LightGray -width 35 \
			-textvariable loadsave(filter)
	pack $Name -side right -anchor nw -padx 5
	bind $Name  {loadsavegetentries}
    	bind $Name  {
		if [%W selection present] {
			%W delete sel.first sel.last
		} else {
			%W delete insert
		}
	}
	#
	#----------
	set Name $Parent.f2.l5
	label $Name  -background LightGray -text "File Type: "
	pack $Name -side right -anchor nw
	
	#------------------------------------------
	set Name $Parent.f3
	frame $Name -background lightgray
	pack $Name -anchor nw -side top -fill x

	#------------------------------------------
	set Name $Parent.f3.e11
	entry $Name  -background white -foreground black \
			-highlightbackground LightGray -width 35 \
			-textvariable loadsave(file)
	pack $Name -side right -anchor nw -padx 5
	.loadsave.f3.e11 delete 0 end
	.loadsave.f3.e11 insert 0 $_F(keyname)
    	bind $Name  {
		if [%W selection present] {
			%W delete sel.first sel.last
		} else {
			%W delete insert
		}
	}
	bind $Name  {if {[loadsavevalentry]} {set loadsave(done) 1}}
	
	#------------------------------------------
	set Name $Parent.f3.l9
	label $Name  -background LightGray -text "File: "
	pack $Name -side right -anchor nw

	#------------------------------------------
	set Name $Parent.f13
	frame $Name  -background LightGray -borderwidth 2 -height 50 \
			-highlightbackground LightGray -relief raised -width 50
	pack $Name -side top -anchor nw -expand yes -fill both
	
	#------------------------------------------
	set Name $Parent.f13.lb1
	listbox $Name  -background white -font $_F(courierfont) \
			-foreground black \
			-highlightbackground LightGray -selectbackground LightBlue \
			-selectforeground black \
			-yscrollcommand "$Parent.f13.sb2 set" -selectmode browse
	pack $Name -anchor center -expand 1 -fill both -ipadx 0 -ipady 0 \
			-padx 2 -pady 2 -side left
    	bind $Name  {loadsaveselbegin %W %y}
    	bind $Name  {loadsaveselbegin2 %W}
    	bind $Name  {loadsaveselbegin %W %y}
    	bind $Name  {loadsaveselbegin %W %y}
    	bind $Name  {set _F(keyname) $seld_file; loadsaveselend %W %y}
	bind $Name  {break}
	bind $Name  {break}
   	bind $Name  {loadsaveselend %W %y}
    	bind $Name  {
		tkCancelRepeat
		tkListboxBeginSelect %W [%W index active]
		%W activate [%W index active]
	}
	bind $Name  {
		tkCancelRepeat
		tkListboxBeginSelect %W [%W index active]
		%W activate [%W index active]
	}
	
	#------------------------------------------
	set Name $Parent.f13.sb2
	scrollbar $Name  -activebackground plum -activerelief sunken \
			-background LightGray -command "$Parent.f13.lb1 yview" \
			-highlightbackground LightGray -troughcolor gray40
	pack $Name -anchor center -expand 0 -fill y -ipadx 0 -ipady 0 \
			-padx 2 -pady 2 -side left
	
	#----------
	set Name $Parent.f14
	frame $Name -background lightgray
	pack $Name -side top -anchor nw -fill x

	#------------------------------------------
	set Name $Parent.f14.b15
	button $Name  -activebackground lavender -background gray40 \
			-foreground white -highlightbackground LightGray -text OK \
			-command {set _F(keyname) [.loadsave.f3.e11 get]; if {[loadsavevalentry]} {set loadsave(done) 1}}
	pack $Name -side left -anchor nw -padx 3 -pady 3
	
	#------------------------------------------
	set Name $Parent.f14.b17
	button $Name  -activebackground lavender -background gray40 \
			-foreground white -highlightbackground LightGray -text Cancel \
			-command {destroy .loadsave}
	pack $Name -side right -anchor nw -padx 3 -pady 3
	
	loadsavegetentries
	wm deiconify .loadsave
	vwait loadsave(done)
	destroy .loadsave
	if {[file isdirectory $loadsave(path)]} {set loadsave(path) ""}
	return $loadsave(path)
}



proc loadsaveselbegin {win ypos} {
	$win select anchor [$win nearest $ypos]
}

proc loadsaveselbegin2 {win} {
global seld_file 

        set seld_file [$win get [$win curselection]]  
        .loadsave.f3.e11 delete 0 end
        .loadsave.f3.e11 insert 0 $seld_file
	set _F(keyname) $seld_file

}
proc loadsaveselend {win ypos} {
	global loadsave _F

#######################
# This "if" will insure that you can't move up the tree beyond the launch directory
#
	if { [$win get [$win curselection]] == "../" } {
		if { [.loadsave.f1.e3 get] == $_F(start_dir) } {return}
	}


	$win select set anchor [$win nearest $ypos]
	set fil [.loadsave.f13.lb1 get [lindex [$win curselection] 0]]
	if {-1 == [string last "/" $fil]} {
		set loadsave(file) $fil
		set loadsave(path) \
				[eval file join $loadsave(pwd) $loadsave(file)]
        set loadsave(done) 1
		return ""
	}
	set loadsave(pwd) [loadsavemergepaths \
			$loadsave(pwd) [string trimright $fil "/"]]
	loadsavegetentries
	return ""
}

proc loadsavegetentries {} {
	global loadsave
	set e 0
	if {![file isdirectory $loadsave(pwd)]} {
		gui_error "\"$loadsave(pwd)\" is not a valid directory"
		.loadsave configure -cursor {}
		set e 1
	}
	.loadsave configure -cursor watch
	update
	if {$loadsave(filter) == ""} {set loadsave(filter) "*"}
	set files [lsort -dictionary "[glob -nocomplain $loadsave(pwd)/.*] [glob -nocomplain $loadsave(pwd)/*]"]
	.loadsave.f13.lb1 delete 0 end
	if {$e} {
		.loadsave configure -cursor {}
		update 
		return
	}
	set d "./ ../"
	set fils ""
	foreach f $files {
		set ff [file tail $f]
		if {$ff != "." && $ff != ".."} {
			if {[file isdirectory $f]} {
				lappend d "$ff/"
			} else {
				if {[string match $loadsave(filter) $ff]} {
					lappend fils "$ff"
				}
			}
		}
	}
	set files "$d $fils"
	foreach f $files {
		.loadsave.f13.lb1 insert end $f
	}
	.loadsave configure -cursor {}
	update 
}

proc loadsavevalentry {} {
	global loadsave _F
	if {"." != [file dirname $loadsave(file)]} {
		set path [loadsavemergepaths \
				$loadsave(pwd) $loadsave(file)]
		set loadsave(pwd) [file dirname $path]
		if {[file extension $path] != ""} {
			set loadsave(filter) "*[file extension $path]"
		} else {
			set loadsave(filter) "*"
		}
		set loadsave(file) [file tail $path]
		loadsavegetentries
		return 0
	}
	set fil [loadsavemergepaths $loadsave(pwd) $loadsave(file)]
	if {$loadsave(loadflag) == 1} {
		if {(![file exists $fil]) || (![file readable $fil])} {
			gui_error "\"$fil\" cannot be loaded."
			set loadsave(path) ""
			return 0
		} else {
			set loadsave(path) $fil
			set _F(file) $fil
			set loadsave(done) 1
			return 1
		}
	} else {
		set d [file dirname $fil]
		if {![file writable $d]} {
			gui_error "\"$d\" directory cannot be written to."
			set loadsave(path) ""
			set _F(file) ""
			return 0
		}
		if {[file exists $fil] && (![file writable $fil])} {
			gui_error "\"$file\" cannot be written to."
			set loadsave(path) ""
			set _F(file) ""
			return 0
		}
		set loadsave(path) $fil
		set loadsave(done) 1
		set _F(file) $fil
		return 1
	}
}

proc loadsavemergepaths {patha pathb} {
	set pa [file split $patha]
	set pb [file split $pathb]
	if {[string first ":" [lindex $pb 0]] != -1} {return [eval file join $pb]}
	if {[lindex $pb 0] == "/"} {return [eval file join $pb]}
	set i [expr [llength $pa] - 1]
	foreach item $pb {
		if {$item == ".."} {
			incr i -1
			set pa [lrange $pa 0 $i]
		} elseif {$item == "."} {
			# -- do nothing
		} else {
			lappend pa $item
		}
	}
	return [eval file join $pa]
}
	
proc gui_error {message} {
	catch "destroy .xxx"
	bell
        tk_dialog .xxx "Error" "$message" warning 0 Close
}

if {[info procs bgerror] == ""} {
	proc bgerror {{message ""}} {
		global errorInfo
		puts stderr $errorInfo
	}
}
#
# End of directory browser section
##################################

##################################
# Use a simple entry box to add clients to the system
#
proc add_client {} {

	toplevel .add_client
	wm title .add_client "Add Client to List"
	entry .add_client.entry -background white -width 60
	pack .add_client.entry -anchor nw -side top -expand 1 -fill x -padx 4 -pady 4
	button .add_client.add -text Add -command {
			.filepush.lists.clients.clientlist insert end [.add_client.entry get]
			.add_client.entry delete 0 end
			.filepush.lists.clients.clientlist yview end
			destroy .add_client
		} -background gray40 -foreground white
	pack .add_client.add -side left -padx 4 -pady 4
	button .add_client.close -text Close -command {destroy .add_client} -background gray40 -foreground white
	pack .add_client.close -side right -padx 4 -pady 4

}

################################
# Start server if there are any clients specified
#
proc start_server {} {
global _PUSH started push_status

	if { ! $started } {
		if {[.filepush.lists.clients.clientlist get 0 end] != ""} {
			set started 1
			wm title .filepush "Tcl File Push Server: waiting"
			push_loop
			pack forget .filepush.buttons.start
			pack .filepush.buttons.stop -anchor nw -side left -expand 1 -fill x -after .filepush.buttons.clients
		}
	}
}

proc stop_server {} {
global started

	set started 0
	wm title .filepush "Tcl File Push Server: idle"
	
}

############################
# This is the main push loop, it repeats after the specified time interval
#
proc push_loop {} {
global interval push_status
	wm title .filepush "Tcl File Push Server: pushing files"
	push_files
	wm title .filepush "Tcl File Push Server: waiting"
	after $interval push_loop

}

######################################
# This is the code that determines which files to push, and then pushes
# them to each client machine, if they have been changed.
# It pushes all of the files in the file list at the first server startup.
# Then it looks for changes in either the file size or the time stamp for each file.
# The "string range..." command strips the launch path from each filename
# prior to pushing, thereby converting the absolute path to a Web-centric relative path.
# The actual pushing is accomplished through RPC invocation of the "fetch_file" proc
# in the PushClnt.tcl script.
#
proc push_files {} {
global _PUSH started _F new_files interval time current_connection

	if { $started } {
		set new_files ""
		set interval [expr $time * 60000]
		puts "\npush started: [clock format [clock seconds]]"

		foreach listed_file [.filepush.lists.files.filelist get 0 end] {
		set fileinfo [file dir -long $listed_file]
		if {$_PUSH($listed_file~~time) != [lindex $fileinfo 5] && $_PUSH($listed_file~~time) != [lindex $fileinfo 2]} {
			set _PUSH($listed_file~~time) [lindex $fileinfo 5]
			set rel_file [string range $listed_file [string length $_F(start_dir)] end]
			lappend new_files $rel_file 
			}		
		}
		 if {$new_files != ""} {puts "Files to push: $new_files"}
	       
		foreach listed_client [.filepush.lists.clients.clientlist get 0 end] {
			if {[catch "set current_connection [dp_MakeRPCClient $listed_client 7658]"]} {
				puts "Error: Could not connect to $listed_client" ; continue}
			if {$new_files != ""} {foreach file_to_push $new_files {
				dp_RPC $current_connection fetch_file $file_to_push
				}
			}
			dp_CloseRPC $current_connection
		}
	}

}

#######################
# This starts the root-level code. 
# First, load the Spynergy Toolkit
#
source spynergy.tcl

#######################
# Set up the global variables and  bindings
#
global _F loadsave interval i password _PUSH started \
	new_files push_status current_connection
set password "theSunalsosets"
set push_status idle
set time 10
set interval 600000
set started 0
set _PUSH(file~~name) ""
set _PUSH(file~~time) ""
bind Entry  {tkEntryBackspace %W}

##########################
# Initialise the variables needed for the directory browser
#
    set _F(start_dir) [pwd]
    set _F(pwd) [pwd]
    set _F(directory) [pwd]
    set _F(file) ""
    set _F(filefilter) "*.*"
    set _F(keyname) ""
    set _F(status) ""
    set _F(permstatus) ""
    set _F(blockflag) 0

	if {$tcl_platform(platform) == "windows"} {
		set _F(courierfont) {{Courier New} 11 {normal}}
	} else {
		set _F(courierfont) "-*-Helvetica-Medium-R-Normal--12-*-*-*-*-*-*-*"
	}

##############################
#  Set up the GUI
#
set Name .filepush
set Parent $Name

    toplevel $Name     -background LightGray
    wm title $Name "Tcl File Push Server "

##############################
#----- The buttons -----

set Name $Parent.buttons
frame $Name     -relief flat -border 0 -background gray40
pack $Name -anchor nw -side top -expand yes -fill both

set Name $Parent.buttons.files
button $Name     -activebackground lavender \
    -background gray40  \
    -command {file_load} \
    -foreground white \
    -highlightbackground LightGray \
    -text "Add Files"
pack $Name -anchor nw -side left -expand 1 -fill x

set Name $Parent.buttons.clients
button $Name     -activebackground lavender \
    -background gray40  \
    -command {add_client} \
    -foreground white \
    -highlightbackground LightGray \
    -text "Add Clients"
pack $Name -anchor nw -side left -expand 1 -fill x

############################
# set up the start and stop buttons so they alternate
#
set Name $Parent.buttons.start
button $Name     -activebackground green \
    -background gray40  \
    -command {
	start_server
	} \
    -foreground green \
    -highlightbackground LightGray \
    -text "Start Server"
pack $Name -anchor nw -side left -expand 1 -fill x

#############################
# Don't pack this one
#
set Name $Parent.buttons.stop
button $Name     -activebackground red \
    -background gray40  \
    -command {
	stop_server
	pack forget $Parent.buttons.stop
	pack $Parent.buttons.start -anchor nw -side left -expand 1 -fill x -after $Parent.buttons.clients
	} \
    -foreground red \
    -highlightbackground LightGray \
    -text "Stop Server"

set Name $Parent.buttons.push
button $Name     -activebackground lavender \
    -background gray40  \
    -command {push_files} \
    -foreground white \
    -highlightbackground LightGray \
    -text "Push Now"
pack $Name -anchor nw -side left -expand 1 -fill x

set Name $Parent.buttons.spacer
label $Name -text "                              " -background gray40 -foreground white
pack $Name -anchor w -side left

set Name $Parent.buttons.exit
button $Name     -activebackground lavender \
    -background gray40 \
    -command exit \
    -foreground white \
    -highlightbackground LightGray \
    -text Exit
pack $Name -anchor nw -side left -expand 1 -fill x

#################################
# Set up the listbox area of the GUI
#
set Name $Parent.lists
frame $Name -border 0
pack $Name 

################################
# This listbox will hold the files to be pushed
#
set Name $Parent.lists.files
frame $Name -border 0
pack $Name 

label $Name.label -text "  Files:"
pack $Name.label -anchor nw -side top

listbox $Name.filelist -width 60 -height 8 -yscrollcommand "$Parent.lists.files.scrollbar set" \
	-background white
pack $Name.filelist -anchor nw -side left 
bind $Name.filelist  {foreach i [$Parent.lists.files.filelist curselection] {$Parent.lists.files.filelist delete $i} }
	
set Name $Parent.lists.files.scrollbar
	scrollbar $Name  -activebackground plum -activerelief sunken \
			-background LightGray -command "$Parent.lists.files.filelist yview" \
			-highlightbackground LightGray -troughcolor gray40
	pack $Name -anchor nw -expand 0 -fill y -ipadx 0 -ipady 0 \
			-padx 2 -pady 2 -side left

###############################
# This listbox will hold the names/IP addresses 
# of the clients to push the files to
#
set Name $Parent.lists.clients
frame $Name -border 0
pack $Name 

label $Name.label -text "  Clients:"
pack $Name.label -anchor nw -side top

listbox $Name.clientlist -width 60 -height 8 -yscrollcommand "$Parent.lists.clients.scrollbar set" \
	-background white
pack $Name.clientlist -anchor nw -side left 
bind $Name.clientlist  {foreach i [$Parent.lists.clients.clientlist curselection] {$Parent.lists.clients.clientlist delete $i} }

	
set Name $Parent.lists.clients.scrollbar
	scrollbar $Name  -activebackground plum -activerelief sunken \
			-background LightGray -command "$Parent.lists.clients.clientlist yview" \
			-highlightbackground LightGray -troughcolor gray40
	pack $Name -anchor nw -expand 0 -fill y -ipadx 0 -ipady 0 \
			-padx 2 -pady 2 -side left

##################################
# Set up the scrollbar for changing the update interval.
# Changes are reflected after the next push.
#
set Name $Parent.timing
frame $Name -border 0
pack $Name

scale $Name.scale -from 0 -to 480 -length 380 -variable time  \
	-orient horizontal -label "Push Interval (minutes):" -tickinterval 80 -showvalue true \
	-troughcolor white
pack $Name.scale -expand 1 -fill x


#end of program