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