00001 # TKE - Advanced Programmer's Editor 00002 # Copyright (C) 2014-2019 Trevor Williams (phase1geo@gmail.com) 00003 # 00004 # This program is free software; you can redistribute it and/or modify 00005 # it under the terms of the GNU General Public License as published by 00006 # the Free Software Foundation; either version 2 of the License, or 00007 # (at your option) any later version. 00008 # 00009 # This program is distributed in the hope that it will be useful, 00010 # but WITHOUT ANY WARRANTY; without even the implied warranty of 00011 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 00012 # GNU General Public License for more details. 00013 # 00014 # You should have received a copy of the GNU General Public License along 00015 # with this program; if not, write to the Free Software Foundation, Inc., 00016 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 00017 00018 ###################################################################### 00019 # Name: remote.tcl 00020 # Author: Trevor Williams (phase1geo@gmail.com) 00021 # Date: 10/10/2016 00022 # Brief: Namespace that provides FTP/SFTP/WebDAV interface support. 00023 ###################################################################### 00024 00025 namespace eval remote { 00026 00027 variable password 00028 variable contents 00029 variable initialized 0 00030 variable current_server "" 00031 variable current_fname "" 00032 00033 array set widgets {} 00034 array set groups {} 00035 array set connections {} 00036 array set opened {} 00037 array set current_dir {} 00038 array set dir_hist {} 00039 00040 set remote_file [file join $::tke_home remote.tkedat] 00041 00042 ###################################################################### 00043 # Initialize the remote namespace. 00044 proc initialize {} { 00045 00046 variable initialized 00047 00048 if {!$initialized} { 00049 00050 # Create images 00051 theme::register_image remote_connecting bitmap ttk_style background \ 00052 {msgcat::mc "Image used in remote file selector to indicate that a connection is being opened."} \ 00053 -file [file join $::tke_dir lib images connecting.bmp] \ 00054 -maskfile [file join $::tke_dir lib images connecting.bmp] \ 00055 -foreground 2 00056 00057 theme::register_image remote_connected bitmap ttk_style background \ 00058 {msgcat::mc "Image used in remote file selector to indicate that a connection is opened."} \ 00059 -file [file join $::tke_dir lib images connected.bmp] \ 00060 -maskfile [file join $::tke_dir lib images connected.bmp] \ 00061 -foreground 2 00062 00063 theme::register_image remote_directory bitmap ttk_style background \ 00064 {msgcat::mc "Image used in remote file selector to indicate a folder."} \ 00065 -file [file join $::tke_dir lib images right.bmp] \ 00066 -maskfile [file join $::tke_dir lib images right.bmp] \ 00067 -foreground 0 00068 00069 theme::register_image remote_file bitmap ttk_style background \ 00070 {msgcat::mc "Image used in remote file selector to indicate a file."} \ 00071 -file [file join $::tke_dir lib images blank.bmp] \ 00072 -maskfile [file join $::tke_dir lib images blank.bmp] \ 00073 -foreground 0 00074 00075 theme::register_image remote_back bitmap ttk_style background \ 00076 {msgcat::mc "Image used in remote file selector for the history back button."} \ 00077 -file [file join $::tke_dir lib images left.bmp] \ 00078 -maskfile [file join $::tke_dir lib images left.bmp] \ 00079 -foreground 2 00080 00081 theme::register_image remote_back_disabled bitmap ttk_style background \ 00082 {msgcat::mc "Image used in remote file selector for the history back button."} \ 00083 -file [file join $::tke_dir lib images left.bmp] \ 00084 -maskfile [file join $::tke_dir lib images left.bmp] \ 00085 -foreground 0 00086 00087 theme::register_image remote_next bitmap ttk_style background \ 00088 {msgcat::mc "Image used in remote file selector for the history forward button."} \ 00089 -file [file join $::tke_dir lib images right.bmp] \ 00090 -maskfile [file join $::tke_dir lib images right.bmp] \ 00091 -foreground 2 00092 00093 theme::register_image remote_next_disabled bitmap ttk_style background \ 00094 {msgcat::mc "Image used in remote file selector for the history forward button."} \ 00095 -file [file join $::tke_dir lib images right.bmp] \ 00096 -maskfile [file join $::tke_dir lib images right.bmp] \ 00097 -foreground 0 00098 00099 set initialized 1 00100 00101 } 00102 00103 } 00104 00105 ###################################################################### 00106 # Creates an remote dialog box and returns the selected file. 00107 proc create {type {save_as ""}} { 00108 00109 variable widgets 00110 variable current_server 00111 variable current_fname 00112 variable connections 00113 00114 # Initialize the namespace 00115 initialize 00116 00117 toplevel .ftp 00118 wm title .ftp [expr {($type eq "open") ? [msgcat::mc "Open Remote File"] : [msgcat::mc "Save File Remotely"]}] 00119 wm transient .ftp . 00120 wm geometry .ftp 600x400 00121 wm withdraw .ftp 00122 00123 set widgets(pw) [ttk::panedwindow .ftp.pw -orient horizontal] 00124 00125 ########### 00126 # SIDEBAR # 00127 ########### 00128 00129 $widgets(pw) add [ttk::frame .ftp.pw.lf] 00130 00131 ttk::frame .ftp.pw.lf.sf 00132 set widgets(sb) [tablelist::tablelist .ftp.pw.lf.sf.tl \ 00133 -columns [list 0 [msgcat::mc "Connections"] 0 {} 0 {}] -treecolumn 0 -exportselection 0 -relief flat \ 00134 -selectmode single -movablerows 1 -labelrelief flat -highlightthickness 0 \ 00135 -labelactivebackground [utils::get_default_background] \ 00136 -labelbackground [utils::get_default_background] \ 00137 -labelforeground [utils::get_default_foreground] \ 00138 -labelactivebackground [utils::get_default_background] \ 00139 -labelactiveforeground [utils::get_default_foreground] \ 00140 -selectbackground [theme::get_value ttk_style active_color] \ 00141 -selectforeground [utils::get_default_foreground] \ 00142 -activestyle none \ 00143 -acceptchildcommand [list remote::accept_child_command] \ 00144 -background [utils::get_default_background] -foreground [utils::get_default_foreground] \ 00145 -yscrollcommand [list utils::set_yscrollbar .ftp.pw.lf.sf.vb]] 00146 scroller::scroller .ftp.pw.lf.sf.vb -orient vertical -command [list .ftp.pw.lf.sf.tl yview] 00147 00148 # Register the scroller for theming 00149 theme::register_widget .ftp.pw.lf.sf.vb misc_scrollbar 00150 00151 $widgets(sb) columnconfigure 0 -name name -editable 0 -resizable 1 -stretchable 1 00152 $widgets(sb) columnconfigure 1 -name settings -hide 1 00153 $widgets(sb) columnconfigure 2 -name passwd -hide 1 00154 00155 bind $widgets(sb) <<TablelistSelect>> [list remote::handle_sb_select] 00156 bind [$widgets(sb) bodytag] <Double-Button-1> [list remote::handle_sb_double_click] 00157 bind [$widgets(sb) bodytag] <Button-$::right_click> [list remote::show_sidebar_menu %W %x %y %X %Y] 00158 bind $widgets(sb) <<TablelistRowMoved>> [list remote::handle_row_moved %d] 00159 00160 grid rowconfigure .ftp.pw.lf.sf 1 -weight 1 00161 grid columnconfigure .ftp.pw.lf.sf 0 -weight 1 00162 grid .ftp.pw.lf.sf.tl -row 0 -column 0 -sticky news -rowspan 2 00163 grid [$widgets(sb) cornerpath] -row 0 -column 1 -sticky ew 00164 grid .ftp.pw.lf.sf.vb -row 1 -column 1 -sticky ns 00165 00166 ttk::frame .ftp.pw.lf.bf 00167 set widgets(new_b) [ttk::button .ftp.pw.lf.bf.edit -style BButton -text "+" -width 2 -command [list remote::show_new_menu]] 00168 00169 pack .ftp.pw.lf.bf.edit -side left -padx 2 -pady 2 00170 00171 pack .ftp.pw.lf.sf -fill both -expand yes 00172 pack .ftp.pw.lf.bf -fill x 00173 00174 # Create contextual menus 00175 set widgets(new) [menu .ftp.newPopup -tearoff 0] 00176 $widgets(new) add command -label [msgcat::mc "New Group"] -command [list remote::new_group] 00177 $widgets(new) add command -label [msgcat::mc "New Connection"] -command [list remote::new_connection] 00178 00179 set widgets(group) [menu .ftp.groupPopup -tearoff 0 -postcommand [list remote::group_post]] 00180 $widgets(group) add command -label [msgcat::mc "New Connection"] -command [list remote::new_connection] 00181 $widgets(group) add separator 00182 $widgets(group) add command -label [msgcat::mc "Rename Group"] -command [list remote::rename_group] 00183 $widgets(group) add command -label [msgcat::mc "Delete Group"] -command [list remote::delete_group] 00184 00185 set widgets(connection) [menu .ftp.connPopup -tearoff 0 -postcommand [list remote::connection_post]] 00186 $widgets(connection) add command -label [msgcat::mc "Open Connection"] -command [list remote::open_connection] 00187 $widgets(connection) add command -label [msgcat::mc "Close Connection"] -command [list remote::close_connection] 00188 $widgets(connection) add separator 00189 $widgets(connection) add command -label [msgcat::mc "Edit Connection"] -command [list remote::edit_connection] 00190 $widgets(connection) add command -label [msgcat::mc "Test Connection"] -command [list remote::test_connection 0] 00191 $widgets(connection) add separator 00192 $widgets(connection) add command -label [msgcat::mc "Delete Connection"] -command [list remote::delete_connection] 00193 00194 ########## 00195 # VIEWER # 00196 ########## 00197 00198 $widgets(pw) add [ttk::frame .ftp.pw.rf] -weight 1 00199 00200 set widgets(viewer) [ttk::frame .ftp.pw.rf.vf] 00201 00202 ttk::frame .ftp.pw.rf.vf.ff 00203 00204 ttk::frame .ftp.pw.rf.vf.ff.mf 00205 set widgets(dir_back) [ttk::button .ftp.pw.rf.vf.ff.mf.back -style BButton -image remote_back_disabled -command [list remote::handle_dir -1] -state disabled] 00206 set widgets(dir_forward) [ttk::button .ftp.pw.rf.vf.ff.mf.forward -style BButton -image remote_next_disabled -command [list remote::handle_dir 1] -state disabled] 00207 set widgets(dir_mb) [ttk::menubutton .ftp.pw.rf.vf.ff.mf.mb \ 00208 -menu [set widgets(dir_menu) [menu .ftp.dirPopup -tearoff 0 -postcommand [list remote::handle_dir_mb_post]]] \ 00209 -state disabled] 00210 00211 pack $widgets(dir_back) -side left -padx 2 -pady 2 00212 pack $widgets(dir_forward) -side left -padx 2 -pady 2 00213 pack $widgets(dir_mb) -side left -padx 2 -pady 2 -fill x -expand yes 00214 00215 set widgets(tl) [tablelist::tablelist .ftp.pw.rf.vf.ff.tl \ 00216 -columns [list 0 [msgcat::mc "File System"] 0 {}] -exportselection 0 -borderwidth 0 -highlightthickness 0 -showlabels 0 \ 00217 -selectmode [expr {($type eq "save") ? "browse" : "extended"}] \ 00218 -xscrollcommand [list utils::set_xscrollbar .ftp.pw.rf.vf.ff.hb] \ 00219 -yscrollcommand [list utils::set_yscrollbar .ftp.pw.rf.vf.ff.vb]] 00220 scroller::scroller .ftp.pw.rf.vf.ff.vb -orient vertical -command [list .ftp.pw.rf.vf.ff.tl yview] 00221 scroller::scroller .ftp.pw.rf.vf.ff.hb -orient horizontal -command [list .ftp.pw.rf.vf.ff.tl xview] 00222 00223 $widgets(tl) columnconfigure 0 -name fname -resizable 1 -stretchable 1 -editable 0 -formatcommand [list remote::format_name] 00224 $widgets(tl) columnconfigure 1 -name dir -hide 1 00225 00226 bind $widgets(tl) <<TablelistSelect>> [list remote::handle_tl_select] 00227 bind [$widgets(tl) bodytag] <Double-Button-1> [list remote::handle_tl_double_click] 00228 00229 grid rowconfigure .ftp.pw.rf.vf.ff 1 -weight 1 00230 grid columnconfigure .ftp.pw.rf.vf.ff 0 -weight 1 00231 grid .ftp.pw.rf.vf.ff.mf -row 0 -column 0 -sticky ew -columnspan 2 00232 grid .ftp.pw.rf.vf.ff.tl -row 1 -column 0 -sticky news 00233 grid .ftp.pw.rf.vf.ff.vb -row 1 -column 1 -sticky ns 00234 grid .ftp.pw.rf.vf.ff.hb -row 2 -column 0 -sticky ew 00235 00236 ttk::frame .ftp.pw.rf.vf.sf 00237 ttk::label .ftp.pw.rf.vf.sf.l -text [format "%s: " [msgcat::mc "Name"]] 00238 set widgets(save_entry) [ttk::entry .ftp.pw.rf.vf.sf.e -validate key -validatecommand [list remote::handle_save_entry %P]] 00239 00240 pack .ftp.pw.rf.vf.sf.l -side left -padx 2 -pady 2 00241 pack .ftp.pw.rf.vf.sf.e -side left -padx 2 -pady 2 -fill x -expand yes 00242 00243 ttk::frame .ftp.pw.rf.vf.bf 00244 set widgets(folder) [ttk::button .ftp.pw.rf.vf.bf.folder -style BButton -text [msgcat::mc "New Folder"] \ 00245 -command [list remote::handle_new_folder] -state disabled] 00246 set widgets(open) [ttk::button .ftp.pw.rf.vf.bf.ok -style BButton -text [msgcat::mc "Open"] \ 00247 -width 6 -command [list remote::handle_open] -state disabled] 00248 ttk::button .ftp.pw.rf.vf.bf.cancel -style BButton -text [msgcat::mc "Cancel"] \ 00249 -width 6 -command [list remote::handle_cancel] 00250 00251 pack .ftp.pw.rf.vf.bf.cancel -side right -padx 2 -pady 2 00252 pack .ftp.pw.rf.vf.bf.ok -side right -padx 2 -pady 2 00253 00254 if {$type ne "open"} { 00255 pack .ftp.pw.rf.vf.bf.folder -side left -padx 2 -pady 2 00256 $widgets(open) configure -text [msgcat::mc "Save"] 00257 } 00258 00259 pack .ftp.pw.rf.vf.ff -fill both -expand yes 00260 if {$type ne "open"} { 00261 pack .ftp.pw.rf.vf.sf -fill x 00262 } 00263 pack .ftp.pw.rf.vf.bf -fill x 00264 00265 pack .ftp.pw.rf.vf -fill both -expand yes 00266 00267 ##################### 00268 # CONNECTION EDITOR # 00269 ##################### 00270 00271 set widgets(editor) [ttk::frame .ftp.ef] 00272 00273 ttk::frame .ftp.ef.sf 00274 ttk::label .ftp.ef.sf.l0 -text [format "%s: " [msgcat::mc "Type"]] 00275 set widgets(edit_type) [ttk::menubutton .ftp.ef.sf.mb0 -text "FTP" -menu [menu .ftp.typePopup -tearoff 0]] 00276 ttk::label .ftp.ef.sf.l1 -text [format "%s: " [msgcat::mc "Group"]] 00277 set widgets(edit_group) [ttk::menubutton .ftp.ef.sf.mb1 -text "" -menu [menu .ftp.egroupPopup -tearoff 0 -postcommand [list remote::populate_group_menu]]] 00278 ttk::label .ftp.ef.sf.l2 -text [format "%s: " [msgcat::mc "Name"]] 00279 set widgets(edit_name) [ttk::entry .ftp.ef.sf.ne -validate key -validatecommand [list remote::check_name %P]] 00280 set widgets(edit_serverl) [ttk::label .ftp.ef.sf.l3 -text [format "%s: " [msgcat::mc "Server"]]] 00281 set widgets(edit_server) [ttk::entry .ftp.ef.sf.se -validate key -validatecommand [list remote::check_server %P]] 00282 ttk::label .ftp.ef.sf.l4 -text [format "%s: " [msgcat::mc "Username"]] 00283 set widgets(edit_user) [ttk::entry .ftp.ef.sf.ue -validate key -validatecommand [list remote::check_username %P]] 00284 ttk::label .ftp.ef.sf.l5 -text [format "%s (%s): " [msgcat::mc "Password"] [msgcat::mc "Optional"]] 00285 set widgets(edit_passwd) [ttk::entry .ftp.ef.sf.pe -show *] 00286 set widgets(edit_portl) [ttk::label .ftp.ef.sf.l6 -text [format "%s: " [msgcat::mc "Port"]]] 00287 set widgets(edit_port) [ttk::entry .ftp.ef.sf.poe -validate key -validatecommand [list remote::check_port %P] -invalidcommand bell] 00288 ttk::label .ftp.ef.sf.l7 -text [format "%s (%s): " [msgcat::mc "Remote Directory"] [msgcat::mc "Optional"]] 00289 set widgets(edit_dir) [ttk::entry .ftp.ef.sf.re -validate key -validatecommand [list remote::check_dir]] 00290 00291 bind $widgets(edit_name) <Return> [list .ftp.ef.bf.create invoke] 00292 bind $widgets(edit_server) <Return> [list .ftp.ef.bf.create invoke] 00293 bind $widgets(edit_user) <Return> [list .ftp.ef.bf.create invoke] 00294 bind $widgets(edit_passwd) <Return> [list .ftp.ef.bf.create invoke] 00295 bind $widgets(edit_port) <Return> [list .ftp.ef.bf.create invoke] 00296 bind $widgets(edit_dir) <Return> [list .ftp.ef.bf.create invoke] 00297 00298 grid rowconfigure .ftp.ef.sf 8 -weight 1 00299 grid columnconfigure .ftp.ef.sf 1 -weight 1 00300 grid .ftp.ef.sf.l0 -row 0 -column 0 -sticky news -padx 2 -pady 2 00301 grid .ftp.ef.sf.mb0 -row 0 -column 1 -sticky w -padx 2 -pady 2 00302 grid .ftp.ef.sf.l1 -row 1 -column 0 -sticky news -padx 2 -pady 2 00303 grid .ftp.ef.sf.mb1 -row 1 -column 1 -sticky w -padx 2 -pady 2 00304 grid .ftp.ef.sf.l2 -row 2 -column 0 -sticky news -padx 2 -pady 2 00305 grid .ftp.ef.sf.ne -row 2 -column 1 -sticky news -padx 2 -pady 2 00306 grid .ftp.ef.sf.l3 -row 3 -column 0 -sticky news -padx 2 -pady 2 00307 grid .ftp.ef.sf.se -row 3 -column 1 -sticky news -padx 2 -pady 2 00308 grid .ftp.ef.sf.l4 -row 4 -column 0 -sticky news -padx 2 -pady 2 00309 grid .ftp.ef.sf.ue -row 4 -column 1 -sticky news -padx 2 -pady 2 00310 grid .ftp.ef.sf.l5 -row 5 -column 0 -sticky news -padx 2 -pady 2 00311 grid .ftp.ef.sf.pe -row 5 -column 1 -sticky news -padx 2 -pady 2 00312 grid .ftp.ef.sf.l6 -row 6 -column 0 -sticky news -padx 2 -pady 2 00313 grid .ftp.ef.sf.poe -row 6 -column 1 -sticky news -padx 2 -pady 2 00314 grid .ftp.ef.sf.l7 -row 7 -column 0 -sticky news -padx 2 -pady 2 00315 grid .ftp.ef.sf.re -row 7 -column 1 -sticky news -padx 2 -pady 2 00316 00317 ttk::frame .ftp.ef.bf 00318 set widgets(edit_test) [ttk::button .ftp.ef.bf.test -style BButton -text [msgcat::mc "Test"] \ 00319 -width 6 -command [list remote::test_connection 1] -state disabled] 00320 set widgets(edit_create) [ttk::button .ftp.ef.bf.create -style BButton -text [msgcat::mc "Create"] \ 00321 -width 6 -command [list remote::update_connection] -state disabled] 00322 ttk::button .ftp.ef.bf.cancel -style BButton -text [msgcat::mc "Cancel"] -width 6 -command { 00323 pack forget .ftp.ef 00324 pack .ftp.pw -fill both -expand yes 00325 } 00326 00327 pack .ftp.ef.bf.test -side left -padx 2 -pady 2 00328 pack .ftp.ef.bf.cancel -side right -padx 2 -pady 2 00329 pack .ftp.ef.bf.create -side right -padx 2 -pady 2 00330 00331 pack .ftp.ef.sf -fill both -expand yes 00332 pack .ftp.ef.bf -fill x 00333 00334 # Pack the main panedwindow 00335 pack .ftp.pw -fill both -expand yes 00336 00337 # Update the UI 00338 update 00339 00340 # Populate sidebar 00341 populate_sidebar 00342 00343 # Set the current directory (if one exists) 00344 if {$current_server ne ""} { 00345 set_current_directory [lindex $connections($current_server) 1 5] 1 00346 } 00347 00348 # Populate the type menubutton 00349 .ftp.typePopup add command -label "FTP" -command { 00350 $remote::widgets(edit_type) configure -text "FTP" 00351 $remote::widgets(edit_serverl) configure -text [format "%s: " [msgcat::mc "Server"]] 00352 $remote::widgets(edit_port) delete 0 end 00353 $remote::widgets(edit_port) insert end 21 00354 grid $remote::widgets(edit_portl) 00355 grid $remote::widgets(edit_port) 00356 } 00357 if {[info procs ::sFTPopen] ne ""} { 00358 .ftp.typePopup add command -label "SFTP" -command { 00359 $remote::widgets(edit_type) configure -text "SFTP" 00360 $remote::widgets(edit_serverl) configure -text [format "%s: " [msgcat::mc "Server"]] 00361 $remote::widgets(edit_port) delete 0 end 00362 $remote::widgets(edit_port) insert end 22 00363 grid $remote::widgets(edit_portl) 00364 grid $remote::widgets(edit_port) 00365 } 00366 } 00367 .ftp.typePopup add command -label "WebDAV" -command { 00368 $remote::widgets(edit_type) configure -text "WebDAV" 00369 $remote::widgets(edit_serverl) configure -text "URL: " 00370 $remote::widgets(edit_port) delete 0 end 00371 grid remove $remote::widgets(edit_portl) 00372 grid remove $remote::widgets(edit_port) 00373 } 00374 00375 # Center the window 00376 ::tk::PlaceWindow .ftp widget . 00377 00378 # Display the window 00379 wm deiconify .ftp 00380 00381 # Figure out which widget should get focus 00382 if {$current_server eq ""} { 00383 00384 set focus_widget $widgets(sb) 00385 $widgets(sb) selection set 0 00386 00387 } else { 00388 00389 # Select the current server in the sidebar 00390 set server_name [join [lassign [split $current_server ,] server_group] ,] 00391 set group_row [$widgets(sb) searchcolumn name $server_group -parent root] 00392 $widgets(sb) selection set [$widgets(sb) searchcolumn name $server_name -parent $group_row] 00393 00394 if {$type eq "open"} { 00395 set focus_widget $widgets(tl) 00396 } else { 00397 set focus_widget $widgets(save_entry) 00398 $widgets(save_entry) insert end $save_as 00399 $widgets(save_entry) selection range 0 end 00400 } 00401 00402 } 00403 00404 # Get the focus 00405 ::tk::SetFocusGrab .ftp $focus_widget 00406 00407 # Wait for the window to close 00408 tkwait window .ftp 00409 00410 # Restore the focus 00411 ::tk::RestoreFocusGrab .ftp $focus_widget 00412 00413 return [list $current_server $current_fname] 00414 00415 } 00416 00417 ###################################################################### 00418 # Formats the file/directory name in the table. 00419 proc format_name {value} { 00420 00421 return [file tail $value] 00422 00423 } 00424 00425 ###################################################################### 00426 # Returns true if the moved row can be placed as a child of the target_parent. 00427 proc accept_child_command {tbl target_parent src} { 00428 00429 if {[$tbl parentkey $src] eq "root"} { 00430 return [expr {$target_parent eq "root"}] 00431 } elseif {[$tbl cellcget $src,name -image] eq ""} { 00432 return [expr {[$tbl parentkey $target_parent] eq "root"}] 00433 } else { 00434 return 0 00435 } 00436 00437 } 00438 00439 ###################################################################### 00440 # Handles any sidebar row moves. 00441 proc handle_row_moved {data} { 00442 00443 # Just save the current connections 00444 save_connections 00445 00446 } 00447 00448 ###################################################################### 00449 # Handle any changes to the save entry. Updates the state of the "Save" 00450 # button. 00451 proc handle_save_entry {value} { 00452 00453 variable widgets 00454 variable current_server 00455 00456 if {($value eq "") || ($current_server eq "")} { 00457 $widgets(open) configure -state disabled 00458 } else { 00459 $widgets(open) configure -state normal 00460 } 00461 00462 return 1 00463 00464 } 00465 00466 ###################################################################### 00467 # Handles a post of the group popup menu. 00468 proc group_post {} { 00469 00470 variable widgets 00471 variable opened 00472 00473 # Get the selected group 00474 set selected [$widgets(sb) curselection] 00475 00476 # Get the group name 00477 set group [$widgets(sb) cellcget $selected,name -text] 00478 00479 # Figure out if any connections are currently opened in this group 00480 set contains_opened [expr {[llength [array names opened $group,*]] > 0}] 00481 00482 # We cannot delete the group if it is the only group or if there is at least one 00483 # opened connection in the group. 00484 if {([llength [$widgets(sb) childkeys root]] == 1) || $contains_opened} { 00485 $widgets(group) entryconfigure [msgcat::mc "Delete Group"] -state disabled 00486 } else { 00487 $widgets(group) entryconfigure [msgcat::mc "Delete Group"] -state normal 00488 } 00489 00490 # We cannot rename the group if it has at least one opened connection 00491 if {$contains_opened} { 00492 $widgets(group) entryconfigure [msgcat::mc "Rename Group"] -state disabled 00493 } else { 00494 $widgets(group) entryconfigure [msgcat::mc "Rename Group"] -state normal 00495 } 00496 00497 } 00498 00499 ###################################################################### 00500 # Handles the connection menu post and makes sure that the states are 00501 # correct for each of the menu items. 00502 proc connection_post {} { 00503 00504 variable widgets 00505 variable opened 00506 00507 # Get the currently selected item 00508 set selected [$widgets(sb) curselection] 00509 00510 # Get the group name 00511 set group_name [$widgets(sb) cellcget [$widgets(sb) parentkey $selected],name -text] 00512 00513 # Get the connection name 00514 set conn_name [$widgets(sb) cellcget $selected,name -text] 00515 00516 # Adjust the state of the menu items 00517 if {[info exists opened($group_name,$conn_name)]} { 00518 $widgets(connection) entryconfigure [msgcat::mc "Open Connection"] -state disabled 00519 $widgets(connection) entryconfigure [msgcat::mc "Close Connection"] -state normal 00520 $widgets(connection) entryconfigure [msgcat::mc "Edit Connection"] -state disabled 00521 $widgets(connection) entryconfigure [msgcat::mc "Test Connection"] -state disabled 00522 $widgets(connection) entryconfigure [msgcat::mc "Delete Connection"] -state disabled 00523 } else { 00524 $widgets(connection) entryconfigure [msgcat::mc "Open Connection"] -state normal 00525 $widgets(connection) entryconfigure [msgcat::mc "Close Connection"] -state disabled 00526 $widgets(connection) entryconfigure [msgcat::mc "Edit Connection"] -state normal 00527 $widgets(connection) entryconfigure [msgcat::mc "Test Connection"] -state normal 00528 $widgets(connection) entryconfigure [msgcat::mc "Delete Connection"] -state normal 00529 } 00530 00531 } 00532 00533 00534 ###################################################################### 00535 # Tests the current connection settings and displays the result message 00536 # in a messageBox. 00537 proc test_connection {edit_mode} { 00538 00539 variable widgets 00540 variable connections 00541 00542 # Get the field values 00543 if {$edit_mode} { 00544 set type [$widgets(edit_type) cget -text] 00545 set group [$widgets(edit_group) cget -text] 00546 set name [$widgets(edit_name) get] 00547 set server [$widgets(edit_server) get] 00548 set user [$widgets(edit_user) get] 00549 set passwd [$widgets(edit_passwd) get] 00550 set port [$widgets(edit_port) get] 00551 set dir [$widgets(edit_dir) get] 00552 } else { 00553 set selected [$widgets(sb) curselection] 00554 set group [$widgets(sb) cellcget [$widgets(sb) parentkey $selected],name -text] 00555 set name [$widgets(sb) cellcget $selected,name -text] 00556 lassign $connections($group,$name) key type server user passwd port dir 00557 } 00558 00559 # Get a password from the user if it is not set 00560 if {$passwd eq ""} { 00561 if {[set passwd [get_password]] eq ""} { 00562 return 00563 } 00564 } 00565 00566 # Open and initialize the connection 00567 switch $type { 00568 "FTP" { 00569 if {[set connection [::ftp::Open $server $user $passwd -port $port -timeout 60]] == -1} { 00570 tk_messageBox -parent .ftp -icon info -type ok -default ok -message [msgcat::mc "Connection failed"] 00571 } else { 00572 ::ftp::Close $connection 00573 tk_messageBox -parent .ftp -icon info -type ok -default ok -message [msgcat::mc "Connection passed"] 00574 } 00575 } 00576 "SFTP" { 00577 if {[::sFTPopen test $server $user $passwd $port 60] == -1} { 00578 tk_messageBox -parent .ftp -icon info -type ok -default ok -message [msgcat::mc "Connection failed"] 00579 } else { 00580 ::sFTPclose test 00581 tk_messageBox -parent .ftp -icon info -type ok -default ok -message [msgcat::mc "Connection passed"] 00582 } 00583 } 00584 "WebDAV" { 00585 if {[catch { webdav::connect $server -username $user -password $passwd } w]} { 00586 tk_messageBox -parent .ftp -icon info -type ok -default ok -message [msgcat::mc "Connection failed"] 00587 } else { 00588 $w close 00589 tk_messageBox -parent .ftp -icon info -type ok -default ok -message [msgcat::mc "Connection passed"] 00590 } 00591 } 00592 } 00593 00594 } 00595 00596 ###################################################################### 00597 # Adds or updates the given connection. 00598 proc update_connection {} { 00599 00600 variable widgets 00601 variable groups 00602 00603 # Get the field values 00604 set type [$widgets(edit_type) cget -text] 00605 set group [$widgets(edit_group) cget -text] 00606 set name [$widgets(edit_name) get] 00607 set server [$widgets(edit_server) get] 00608 set user [$widgets(edit_user) get] 00609 set passwd [$widgets(edit_passwd) get] 00610 set port [$widgets(edit_port) get] 00611 set dir [$widgets(edit_dir) get] 00612 00613 # Create the settings list 00614 set settings [list $type $server $user $passwd $port $dir] 00615 00616 # Update the sidebar 00617 if {[$widgets(edit_create) cget -text] eq [msgcat::mc "Create"]} { 00618 $widgets(sb) insertchild $groups($group) end [list $name $settings $passwd] 00619 } else { 00620 set selected [$widgets(sb) curselection] 00621 set current_group [$widgets(sb) cellcget [$widgets(sb) parentkey $selected],name -text] 00622 set current_name [$widgets(sb) cellcget $selected,name -text] 00623 if {$group ne $current_group} { 00624 $widgets(sb) delete $selected 00625 $widgets(sb) insertchild $groups($group) end [list $name $settings $passwd] 00626 } else { 00627 $widgets(sb) rowconfigure $selected -text [list $name $settings $passwd] 00628 } 00629 } 00630 00631 # Write the connection information to file 00632 save_connections 00633 00634 # Make the file table visible 00635 pack forget $widgets(editor) 00636 pack $widgets(pw) -fill both -expand yes 00637 00638 } 00639 00640 ###################################################################### 00641 # Populates the group menu. 00642 proc populate_group_menu {} { 00643 00644 variable widgets 00645 00646 # Remove all items from the group popup menu 00647 .ftp.egroupPopup delete 0 end 00648 00649 foreach group_key [$widgets(sb) childkeys root] { 00650 set group [$widgets(sb) cellcget $group_key,name -text] 00651 .ftp.egroupPopup add command -label $group -command [list remote::change_group $group] 00652 } 00653 00654 } 00655 00656 ###################################################################### 00657 # Changes the group value of the group widget. 00658 proc change_group {value} { 00659 00660 variable widgets 00661 00662 # Update the group menubutton text 00663 $widgets(edit_group) configure -text $value 00664 00665 # If the create button is Update, potentially update the button state 00666 if {[$widgets(edit_create) cget -text] eq [msgcat::mc "Update"]} { 00667 if {([$widgets(edit_name) get] ne "") && \ 00668 ([$widgets(edit_server) get] ne "") && \ 00669 ([$widgets(edit_user) get] ne "") && \ 00670 ([$widgets(edit_passwd) get] ne "") && \ 00671 ([$widgets(edit_port) get] ne "")} { 00672 $widgets(edit_create) configure -state normal 00673 $widgets(edit_test) configure -state normal 00674 } else { 00675 $widgets(edit_create) configure -state disabled 00676 $widgets(edit_test) configure -state disabled 00677 } 00678 } 00679 00680 } 00681 00682 ###################################################################### 00683 # Checks the connection name and handles the state of the Create button. 00684 proc check_name {value} { 00685 00686 variable widgets 00687 00688 set type [$widgets(edit_type) cget -text] 00689 00690 if {($value ne "") && \ 00691 ([$widgets(edit_server) get] ne "") && \ 00692 ([$widgets(edit_user) get] ne "") && \ 00693 (([$widgets(edit_port) get] ne "") || ($type eq "WebDAV"))} { 00694 $widgets(edit_create) configure -state normal 00695 $widgets(edit_test) configure -state normal 00696 } else { 00697 $widgets(edit_create) configure -state disabled 00698 $widgets(edit_test) configure -state disabled 00699 } 00700 00701 return 1 00702 00703 } 00704 00705 ###################################################################### 00706 # Checks the connection server and handles the state of the Create button. 00707 proc check_server {value} { 00708 00709 variable widgets 00710 00711 set type [$widgets(edit_type) cget -text] 00712 00713 if {([$widgets(edit_name) get] ne "") && \ 00714 ($value ne "") && \ 00715 ([$widgets(edit_user) get] ne "") && \ 00716 (([$widgets(edit_port) get] ne "") || ($type eq "WebDAV"))} { 00717 $widgets(edit_create) configure -state normal 00718 $widgets(edit_test) configure -state normal 00719 } else { 00720 $widgets(edit_create) configure -state disabled 00721 $widgets(edit_test) configure -state disabled 00722 } 00723 00724 return 1 00725 00726 } 00727 00728 ###################################################################### 00729 # Checks the connection server and handles the state of the Create button. 00730 proc check_username {value} { 00731 00732 variable widgets 00733 00734 set type [$widgets(edit_type) cget -text] 00735 00736 if {([$widgets(edit_name) get] ne "") && \ 00737 ([$widgets(edit_server) get] ne "") && \ 00738 ($value ne "") && \ 00739 (([$widgets(edit_port) get] ne "") || ($type eq "WebDAV"))} { 00740 $widgets(edit_create) configure -state normal 00741 $widgets(edit_test) configure -state normal 00742 } else { 00743 $widgets(edit_create) configure -state disabled 00744 $widgets(edit_test) configure -state disabled 00745 } 00746 00747 return 1 00748 00749 } 00750 00751 ###################################################################### 00752 # Checks the connection port and handles the state of the Create button. 00753 proc check_port {value} { 00754 00755 variable widgets 00756 00757 # If the value is not an integer, complain 00758 if {($value ne "") && ![string is integer $value]} { 00759 return 0 00760 } 00761 00762 set type [$widgets(edit_type) cget -text] 00763 00764 if {([$widgets(edit_name) get] ne "") && \ 00765 ([$widgets(edit_server) get] ne "") && \ 00766 ([$widgets(edit_user) get] ne "") && \ 00767 (($value ne "") || ($type eq "WebDAV"))} { 00768 $widgets(edit_create) configure -state normal 00769 $widgets(edit_test) configure -state normal 00770 } else { 00771 $widgets(edit_create) configure -state disabled 00772 $widgets(edit_test) configure -state disabled 00773 } 00774 00775 return 1 00776 00777 } 00778 00779 ###################################################################### 00780 # Updates the UI state when the user makes a modification to the 00781 # directory field. 00782 proc check_dir {} { 00783 00784 variable widgets 00785 00786 set type [$widgets(edit_type) cget -text] 00787 00788 if {([$widgets(edit_name) get] ne "") && \ 00789 ([$widgets(edit_server) get] ne "") && \ 00790 ([$widgets(edit_user) get] ne "") && \ 00791 (([$widgets(edit_port) get] ne "") || ($type eq "WebDAV"))} { 00792 $widgets(edit_create) configure -state normal 00793 $widgets(edit_test) configure -state normal 00794 } else { 00795 $widgets(edit_create) configure -state disabled 00796 $widgets(edit_test) configure -state disabled 00797 } 00798 00799 return 1 00800 00801 } 00802 00803 ###################################################################### 00804 # Handles a single select of the sidebar tablelist. 00805 proc handle_sb_select {} { 00806 00807 variable widgets 00808 variable opened 00809 00810 # Get the selection 00811 set selected [$widgets(sb) curselection] 00812 00813 # We don't want to do anything when double-clicking a group 00814 if {[set parent [$widgets(sb) parentkey $selected]] eq "root"} { 00815 return 00816 } 00817 00818 # Get the group name 00819 set group [$widgets(sb) cellcget $parent,name -text] 00820 00821 # Get the remote name 00822 set name "$group,[$widgets(sb) cellcget $selected,name -text]" 00823 00824 # If the connection is already opened, immediately display the directory contents 00825 if {[info exists opened($name)]} { 00826 # open_connection 00827 } 00828 00829 } 00830 00831 ###################################################################### 00832 # Handles a selection of a connection. 00833 proc handle_sb_double_click {} { 00834 00835 variable widgets 00836 00837 # Get the selection 00838 set selected [$widgets(sb) curselection] 00839 00840 # We don't want to do anything when double-clicking a group 00841 if {[set parent [$widgets(sb) parentkey $selected]] eq "root"} { 00842 return 00843 } 00844 00845 # Open the connection of the selected row 00846 open_connection 00847 00848 } 00849 00850 ###################################################################### 00851 # Shows the sidebar menu 00852 proc show_sidebar_menu {W x y X Y} { 00853 00854 variable widgets 00855 00856 foreach {tbl x y} [tablelist::convEventFields $W $x $y] {} 00857 00858 set row [$tbl containing $y] 00859 if {$row == -1} { 00860 return 00861 } 00862 00863 # Set the current selection 00864 $widgets(sb) selection clear 0 end 00865 $widgets(sb) selection set $row 00866 00867 if {[$widgets(sb) parentkey $row] eq "root"} { 00868 set mnu $widgets(group) 00869 } else { 00870 set mnu $widgets(connection) 00871 } 00872 00873 tk_popup $mnu $X $Y 00874 00875 } 00876 00877 ###################################################################### 00878 # Displays the new menu. 00879 proc show_new_menu {} { 00880 00881 variable widgets 00882 00883 set menu_width [winfo reqwidth $widgets(new)] 00884 set menu_height [winfo reqheight $widgets(new)] 00885 set w_width [winfo width $widgets(new_b)] 00886 set w_x [winfo rootx $widgets(new_b)] 00887 set w_y [winfo rooty $widgets(new_b)] 00888 00889 set x $w_x 00890 set y [expr $w_y - ($menu_height + 4)] 00891 00892 tk_popup $widgets(new) $x $y 00893 00894 } 00895 00896 ###################################################################### 00897 # Allows the user to create a new group and inserts it into the sidebar. 00898 proc new_group {} { 00899 00900 variable widgets 00901 variable value 00902 variable groups 00903 00904 set value "" 00905 00906 toplevel .groupwin 00907 wm title .groupwin [msgcat::mc "New Group"] 00908 wm resizable .groupwin 0 0 00909 wm transient .groupwin .ftp 00910 00911 ttk::frame .groupwin.f 00912 ttk::label .groupwin.f.l -text [msgcat::mc "Group Name: "] 00913 ttk::entry .groupwin.f.e -validate key -validatecommand [list remote::validate_group %P] 00914 00915 bind .groupwin.f.e <Return> [list .groupwin.bf.create invoke] 00916 00917 pack .groupwin.f.l -side left -padx 2 -pady 2 00918 pack .groupwin.f.e -side left -padx 2 -pady 2 -fill x -expand yes 00919 00920 ttk::frame .groupwin.bf 00921 ttk::button .groupwin.bf.create -style BButton -text [msgcat::mc "Create"] -width 6 -command { 00922 set remote::value [.groupwin.f.e get] 00923 destroy .groupwin 00924 } -state disabled 00925 ttk::button .groupwin.bf.cancel -style BButton -text [msgcat::mc "Cancel"] -width 6 -command { 00926 set remote::value "" 00927 destroy .groupwin 00928 } 00929 00930 pack .groupwin.bf.cancel -side right -padx 2 -pady 2 00931 pack .groupwin.bf.create -side right -padx 2 -pady 2 00932 00933 pack .groupwin.f -fill x -expand yes 00934 pack .groupwin.bf -fill x 00935 00936 # Place the window in the middle of the FTP window 00937 ::tk::PlaceWindow .groupwin widget .ftp 00938 00939 # Get the focus/grab 00940 ::tk::SetFocusGrab .groupwin .groupwin.f.e 00941 00942 # Wait for the window to close 00943 tkwait window .groupwin 00944 00945 # Restore the focus/grab 00946 ::tk::RestoreFocusGrab .groupwin .groupwin.f.e 00947 00948 # Add the group to the sidebar table 00949 if {$value ne ""} { 00950 set groups($value) [$widgets(sb) insertchild root end [list $value "" ""]] 00951 $widgets(sb) selection clear 0 end 00952 $widgets(sb) selection set $groups($value) 00953 } 00954 00955 } 00956 00957 ###################################################################### 00958 # Validates the group name entry value. 00959 proc validate_group {value} { 00960 00961 if {$value eq ""} { 00962 .groupwin.bf.create configure -state disabled 00963 } else { 00964 .groupwin.bf.create configure -state normal 00965 } 00966 00967 return 1 00968 00969 } 00970 00971 ###################################################################### 00972 # Renames the currently selected group. 00973 proc rename_group {} { 00974 00975 variable widgets 00976 variable value 00977 variable groups 00978 00979 # Get the currently selected group 00980 set selected [$widgets(sb) curselection] 00981 set old_value [$widgets(sb) cellcget $selected,name -text] 00982 set value "" 00983 00984 toplevel .renwin 00985 wm title .renwin [format "%s %s" [msgcat::mc "Rename Group"] $old_value] 00986 wm resizable .renwin 0 0 00987 wm transient .renwin .ftp 00988 00989 ttk::frame .renwin.f 00990 ttk::label .renwin.f.l -text [format "%s: " [msgcat::mc "Group Name"]] 00991 ttk::entry .renwin.f.e -validate key -validatecommand [list remote::validate_rename_group %P] 00992 00993 bind .renwin.f.e <Return> [list .renwin.bf.ok invoke] 00994 00995 pack .renwin.f.l -side left -padx 2 -pady 2 00996 pack .renwin.f.e -side left -padx 2 -pady 2 -fill x -expand yes 00997 00998 ttk::frame .renwin.bf 00999 ttk::button .renwin.bf.ok -style BButton -text [msgcat::mc "Rename"] -width 6 -command { 01000 set remote::value [.renwin.f.e get] 01001 destroy .renwin 01002 } -state disabled 01003 ttk::button .renwin.bf.cancel -style BButton -text [msgcat::mc "Cancel"] -width 6 -command { 01004 set remote::value "" 01005 destroy .renwin 01006 } 01007 01008 pack .renwin.bf.cancel -side right -padx 2 -pady 2 01009 pack .renwin.bf.ok -side right -padx 2 -pady 2 01010 01011 pack .renwin.f -fill x -expand yes 01012 pack .renwin.bf -fill x 01013 01014 # Place the window in the middle of the FTP window 01015 ::tk::PlaceWindow .renwin widget .ftp 01016 01017 # Get the focus/grab 01018 ::tk::SetFocusGrab .renwin .renwin.f.e 01019 01020 # Wait for the window to close 01021 tkwait window .renwin 01022 01023 # Restore the focus/grab 01024 ::tk::RestoreFocusGrab .renwin .renwin.f.e 01025 01026 # Add the group to the sidebar table 01027 if {$value ne ""} { 01028 $widgets(sb) cellconfigure $selected,name -text $value 01029 unset groups($old_value) 01030 set groups($value) $selected 01031 save_connections 01032 } 01033 01034 } 01035 01036 ###################################################################### 01037 # Validate the group name in the group rename window. 01038 proc validate_rename_group {value} { 01039 01040 variable widgets 01041 01042 if {$value eq ""} { 01043 .renwin.bf.ok configure -state disabled 01044 } else { 01045 .renwin.bf.ok configure -state normal 01046 } 01047 01048 return 1 01049 01050 } 01051 01052 ###################################################################### 01053 # Deletes the currently selected group. 01054 proc delete_group {} { 01055 01056 variable widgets 01057 01058 # Verify that the user wants to delete the connection 01059 if {[tk_messageBox -parent .ftp -icon question -type yesno -default no -message [msgcat::mc "Delete group?"]] eq "no"} { 01060 return 01061 } 01062 01063 # Get the currently selected group 01064 set selected [$widgets(sb) curselection] 01065 01066 # Delete the group from the sidebar 01067 $widgets(sb) delete $selected 01068 01069 # Save the connection information 01070 save_connections 01071 01072 } 01073 01074 ###################################################################### 01075 # Clears the editor fields. 01076 proc clear_editor_fields {} { 01077 01078 variable widgets 01079 01080 $widgets(edit_type) configure -text "FTP" 01081 $widgets(edit_name) delete 0 end 01082 $widgets(edit_name) configure -state normal 01083 $widgets(edit_server) delete 0 end 01084 $widgets(edit_user) delete 0 end 01085 $widgets(edit_passwd) delete 0 end 01086 $widgets(edit_port) delete 0 end 01087 $widgets(edit_dir) delete 0 end 01088 01089 } 01090 01091 ###################################################################### 01092 # Allows the user to create a new connection and inserts it into the sidebar. 01093 proc new_connection {} { 01094 01095 variable widgets 01096 01097 # Get the current selection and group name 01098 if {[set selected [$widgets(sb) curselection]] eq ""} { 01099 set group_name [$widgets(sb) cellcget [lindex [$widgets(sb) childkeys root] 0],name -text] 01100 } elseif {[$widgets(sb) parentkey $selected] eq "root"} { 01101 set group_name [$widgets(sb) cellcget $selected,name -text] 01102 } else { 01103 set group_name [$widgets(sb) cellcget [$widgets(sb) parentkey $selected],name -text] 01104 } 01105 01106 # Clear out the editor fields 01107 clear_editor_fields 01108 01109 # Setup field names 01110 $widgets(edit_type) configure -text "FTP" 01111 $widgets(edit_group) configure -text $group_name 01112 $widgets(edit_port) insert end 21 01113 01114 # Set the create button text to Create 01115 $widgets(edit_create) configure -text [msgcat::mc "Create"] 01116 01117 # Make the editor pane visible 01118 pack forget $widgets(pw) 01119 pack $widgets(editor) -fill both -expand yes 01120 01121 } 01122 01123 ###################################################################### 01124 # Open connection for the currently selected row in the sidebar. 01125 proc open_connection {} { 01126 01127 variable widgets 01128 variable current_server 01129 variable images 01130 variable opened 01131 variable dir_hist 01132 variable dir_hist_index 01133 01134 # Get the selection 01135 set selected [$widgets(sb) curselection] 01136 01137 # Get the group name 01138 set parent [$widgets(sb) parentkey $selected] 01139 set group [$widgets(sb) cellcget $parent,name -text] 01140 01141 # Get the connection name to load 01142 set current_server "$group,[$widgets(sb) cellcget $selected,name -text]" 01143 01144 # Get settings 01145 set settings [$widgets(sb) cellcget $selected,settings -text] 01146 01147 if {[info exists opened($current_server)]} { 01148 01149 # Set the current directory 01150 set_current_directory [lindex $settings 5] 1 01151 01152 # Indicate that the we are connected 01153 $widgets(sb) cellconfigure $selected,name -image remote_connected 01154 01155 # Make sure that the Open/Save button is enabled 01156 if {([$widgets(open) configure -text] eq [msgcat::mc "Open"]) || \ 01157 ([$widgets(save_entry) get] ne "")} { 01158 $widgets(open) configure -state normal 01159 } 01160 01161 } else { 01162 01163 # Set the image to indicate that we are connecting 01164 $widgets(sb) cellconfigure $selected,name -image remote_connecting 01165 01166 # Connect to the FTP server and add the directory 01167 if {[connect $current_server]} { 01168 01169 # Clear the directory history 01170 set dir_hist($current_server) [list] 01171 set dir_hist_index($current_server) 0 01172 01173 # Display the current directory 01174 set_current_directory [lindex $settings 5] 1 01175 01176 # Indicate that we have successfully connected to the server 01177 $widgets(sb) cellconfigure $selected,name -image remote_connected 01178 01179 # Make sure that the Open/Save button is enabled 01180 if {([$widgets(open) configure -text] eq [msgcat::mc "Open"]) || \ 01181 ([$widgets(save_entry) get] ne "")} { 01182 $widgets(open) configure -state normal 01183 } 01184 01185 # If we fail to connect, clear the connecting icon 01186 } else { 01187 $widgets(sb) cellconfigure $selected,name -image "" 01188 } 01189 01190 } 01191 01192 } 01193 01194 ###################################################################### 01195 # Closes the currently opened connection 01196 proc close_connection {} { 01197 01198 variable widgets 01199 01200 # Get the currently selected connection 01201 set selected [$widgets(sb) curselection] 01202 01203 # Get the group name 01204 set group_name [$widgets(sb) cellcget [$widgets(sb) parentkey $selected],name -text] 01205 01206 # Get the connection name 01207 set conn_name [$widgets(sb) cellcget $selected,name -text] 01208 01209 # Disconnect, if necessary 01210 sidebar::disconnect_by_name "$group_name,$conn_name" 01211 disconnect "$group_name,$conn_name" 01212 01213 # Clear the icon 01214 $widgets(sb) cellconfigure $selected,name -image "" 01215 01216 # Clear the table 01217 $widgets(tl) delete 0 end 01218 01219 # Make sure that the Open/Save button is disabled 01220 $widgets(open) configure -state disabled 01221 01222 # Disable the New Folder button 01223 $widgets(folder) configure -state disabled 01224 01225 # Make sure that the directory widgets are disabled 01226 $widgets(dir_back) configure -state disabled -image remote_back_disabled 01227 $widgets(dir_forward) configure -state disabled -image remote_next_disabled 01228 $widgets(dir_mb) configure -text "" -state disabled 01229 01230 } 01231 01232 ###################################################################### 01233 # Edits the currently selected connection information. 01234 proc edit_connection {} { 01235 01236 variable widgets 01237 01238 # Get the currently selected connection 01239 set selected [$widgets(sb) curselection] 01240 01241 # Get the group name 01242 set group_name [$widgets(sb) cellcget [$widgets(sb) parentkey $selected],name -text] 01243 01244 # Get the connection name 01245 set conn_name [$widgets(sb) cellcget $selected,name -text] 01246 01247 # Get the settings 01248 set settings [$widgets(sb) cellcget $selected,settings -text] 01249 01250 # Clear the editor fields 01251 clear_editor_fields 01252 01253 # Insert field values 01254 $widgets(edit_type) configure -text [lindex $settings 0] 01255 $widgets(edit_group) configure -text $group_name 01256 $widgets(edit_name) insert end $conn_name 01257 $widgets(edit_server) insert end [lindex $settings 1] 01258 $widgets(edit_user) insert end [lindex $settings 2] 01259 $widgets(edit_passwd) insert end [lindex $settings 3] 01260 $widgets(edit_port) insert end [lindex $settings 4] 01261 $widgets(edit_dir) insert end [lindex $settings 5] 01262 01263 # Set the create button text to Update 01264 $widgets(edit_create) configure -text [msgcat::mc "Update"] -state disabled 01265 01266 # Make the editor pane visible 01267 pack forget $widgets(pw) 01268 pack $widgets(editor) -fill both -expand yes 01269 01270 } 01271 01272 ###################################################################### 01273 # Deletes the current connection. 01274 proc delete_connection {} { 01275 01276 variable widgets 01277 01278 # Verify that the user wants to delete the connection 01279 if {[tk_messageBox -parent .ftp -icon question -type yesno -default no -message [msgcat::mc "Delete connection?"]] eq "no"} { 01280 return 01281 } 01282 01283 # Get the currently selected item 01284 set selected [$widgets(sb) curselection] 01285 01286 # Delete the connection from the table 01287 $widgets(sb) delete $selected 01288 01289 # Save the connections information to file 01290 save_connections 01291 01292 } 01293 01294 ###################################################################### 01295 # Validates the group name entry value. 01296 proc validate_group {value} { 01297 01298 if {$value eq ""} { 01299 .groupwin.bf.create configure -state disabled 01300 } else { 01301 .groupwin.bf.create configure -state normal 01302 } 01303 01304 return 1 01305 01306 } 01307 01308 ##################### 01309 # VIEWER PROCEDURES # 01310 ##################### 01311 01312 ###################################################################### 01313 # Handles a click on the directory back/forward buttons. 01314 proc handle_dir {dir} { 01315 01316 variable widgets 01317 variable dir_hist 01318 variable dir_hist_index 01319 variable current_server 01320 01321 incr dir_hist_index($current_server) $dir 01322 01323 # Set the current directory 01324 set_current_directory [lindex $dir_hist($current_server) $dir_hist_index($current_server)] 0 01325 01326 if {$dir_hist_index($current_server) == 0} { 01327 $widgets(dir_back) configure -state disabled -image remote_back_disabled 01328 } else { 01329 $widgets(dir_back) configure -state normal -image remote_back 01330 } 01331 01332 if {[expr ($dir_hist_index($current_server) + 1) == [llength $dir_hist($current_server)]]} { 01333 $widgets(dir_forward) configure -state disabled -image remote_next_disabled 01334 } else { 01335 $widgets(dir_forward) configure -state normal -image remote_next 01336 } 01337 01338 } 01339 01340 ###################################################################### 01341 # Handles a post event of the directory popup menu. 01342 proc handle_dir_mb_post {} { 01343 01344 variable widgets 01345 variable current_server 01346 variable current_dir 01347 01348 # Get the directory list 01349 set dir_list [file split $current_dir($current_server)] 01350 01351 # Clear the menu 01352 $widgets(dir_menu) delete 0 end 01353 01354 for {set i 0} {$i < [llength $dir_list]} {incr i} { 01355 set dir [file join {*}[lrange $dir_list 0 $i]] 01356 $widgets(dir_menu) add command -label $dir -command [list remote::set_current_directory $dir 1] 01357 } 01358 01359 } 01360 01361 ###################################################################### 01362 # Handles a selection of a file in the file viewer. 01363 proc handle_tl_select {} { 01364 01365 variable widgets 01366 01367 # Get the currently selected row 01368 set selected [$widgets(tl) curselection] 01369 01370 # If the selected item is a file 01371 if {([$widgets(open) cget -text] eq [msgcat::mc "Open"]) || \ 01372 ([$widgets(tl) cellcget $selected,dir -text] == 0)} { 01373 01374 # Populate the save entry field 01375 $widgets(save_entry) delete 0 end 01376 $widgets(save_entry) insert end [file tail [$widgets(tl) cellcget $selected,fname -text]] 01377 01378 if {[$widgets(save_entry) get] ne ""} { 01379 $widgets(open) configure -state normal 01380 } else { 01381 $widgets(open) configure -state disabled 01382 } 01383 01384 } 01385 01386 } 01387 01388 ###################################################################### 01389 # Handles a double-click in the file browser. 01390 proc handle_tl_double_click {} { 01391 01392 variable widgets 01393 01394 # Get the current selection 01395 set selected [$widgets(tl) curselection] 01396 01397 if {[$widgets(tl) cellcget $selected,dir -text] == 0} { 01398 01399 handle_tl_select 01400 handle_open 01401 01402 } else { 01403 01404 set_current_directory [$widgets(tl) cellcget $selected,fname -text] 1 01405 01406 } 01407 01408 } 01409 01410 ###################################################################### 01411 # Handles a click on the sidebar Edit button. 01412 proc edit_sidebar {} { 01413 01414 pref_ui::create "" "" general ftp 01415 01416 } 01417 01418 ###################################################################### 01419 # Populates the sidebar with connection information. 01420 proc populate_sidebar {} { 01421 01422 variable widgets 01423 variable groups 01424 variable current_server 01425 01426 # Clear variables 01427 array unset groups 01428 01429 # Read the contents of the FTP file and load them into the sidebar table 01430 load_connections 01431 01432 } 01433 01434 ###################################################################### 01435 # Get the connection password from the user. 01436 proc get_password {} { 01437 01438 variable password 01439 01440 set password "" 01441 01442 toplevel .ftppass 01443 wm title .ftppass [msgcat::mc "Enter Password"] 01444 wm transient .ftppass .ftp 01445 01446 ttk::frame .ftppass.f 01447 ttk::label .ftppass.f.l -text [msgcat::mc "Password: "] 01448 ttk::entry .ftppass.f.e -validate key -validatecommand [list remote::check_password %P] -textvariable remote::password -show * -width 30 01449 01450 bind .ftppass.f.e <Return> [list .ftppass.bf.ok invoke] 01451 01452 pack .ftppass.f.l -side left -padx 2 -pady 2 01453 pack .ftppass.f.e -side left -padx 2 -pady 2 -fill x -expand yes 01454 01455 ttk::frame .ftppass.bf 01456 ttk::button .ftppass.bf.ok -style BButton -text [msgcat::mc "OK"] -width 6 -command [list remote::password_ok] -state disabled 01457 ttk::button .ftppass.bf.cancel -style BButton -text [msgcat::mc "Cancel"] -width 6 -command [list remote::password_cancel] 01458 01459 pack .ftppass.bf.cancel -side right -padx 2 -pady 2 01460 pack .ftppass.bf.ok -side right -padx 2 -pady 2 01461 01462 pack .ftppass.f -fill x -expand yes 01463 pack .ftppass.bf -fill x 01464 01465 # Center the password window 01466 ::tk::PlaceWindow .ftppass widget .ftp 01467 01468 # Get the focus/grab 01469 ::tk::SetFocusGrab .ftppass .ftppass.f.e 01470 01471 # Wait for the window to close 01472 tkwait window .ftppass 01473 01474 # Restore the focus/grab 01475 ::tk::RestoreFocusGrab .ftppass .ftppass.f.e 01476 01477 return $password 01478 01479 } 01480 01481 ###################################################################### 01482 # Checks the given password and sets the OK button state accordingly. 01483 proc check_password {value} { 01484 01485 if {$value eq ""} { 01486 .ftppass.bf.ok configure -state disabled 01487 } else { 01488 .ftppass.bf.ok configure -state normal 01489 } 01490 01491 return 1 01492 01493 } 01494 01495 ###################################################################### 01496 # Handles an OK click in the password window. 01497 proc password_ok {} { 01498 01499 destroy .ftppass 01500 01501 } 01502 01503 ###################################################################### 01504 # Handles a Cancel click in the password window. 01505 proc password_cancel {} { 01506 01507 variable password 01508 01509 set password "" 01510 01511 destroy .ftppass 01512 01513 } 01514 01515 ###################################################################### 01516 # Handles a click on the New Folder button. 01517 proc handle_new_folder {} { 01518 01519 variable widgets 01520 variable value 01521 variable current_dir 01522 variable current_server 01523 01524 toplevel .foldwin 01525 wm title .foldwin [msgcat::mc "Create New Folder"] 01526 wm resizable .foldwin 0 0 01527 wm transient .foldwin .ftp 01528 01529 ttk::frame .foldwin.f 01530 ttk::label .foldwin.f.l -text [format "%s: " [msgcat::mc "Folder Name"]] 01531 ttk::entry .foldwin.f.e -validate key -validatecommand [list remote::check_folder_name %P] 01532 01533 bind .foldwin.f.e <Return> [list .foldwin.bf.ok invoke] 01534 01535 pack .foldwin.f.l -side left -padx 2 -pady 2 01536 pack .foldwin.f.e -side left -padx 2 -pady 2 -fill x -expand yes 01537 01538 ttk::frame .foldwin.bf 01539 ttk::button .foldwin.bf.ok -style BButton -text [msgcat::mc "Create"] -width 6 -command { 01540 set remote::value [.foldwin.f.e get] 01541 destroy .foldwin 01542 } -state disabled 01543 ttk::button .foldwin.bf.cancel -style BButton -text [msgcat::mc "Cancel"] -width 6 -command { 01544 set remote::value "" 01545 destroy .foldwin 01546 } 01547 01548 pack .foldwin.bf.cancel -side right -padx 2 -pady 2 01549 pack .foldwin.bf.ok -side right -padx 2 -pady 2 01550 01551 pack .foldwin.f -fill x -expand yes 01552 pack .foldwin.bf -fill x 01553 01554 # Center the window 01555 ::tk::PlaceWindow .foldwin widget .ftp 01556 01557 # Get the grab/focus 01558 ::tk::SetFocusGrab .foldwin .foldwin.f.e 01559 01560 # Wait for the window to close 01561 tkwait window .foldwin 01562 01563 # Restore the grab/focus 01564 ::tk::RestoreFocusGrab .foldwin .foldwin.f.e 01565 01566 # Get the name of the folder to create 01567 set new_folder [file join $current_dir($current_server) $value] 01568 01569 # Insert the new directory, if it is successfully made within FTP 01570 if {[make_directory $current_server $new_folder]} { 01571 set_current_directory $new_folder 1 01572 } 01573 01574 } 01575 01576 ###################################################################### 01577 # Checks the folder name and updates the UI appropriately. 01578 proc check_folder_name {value} { 01579 01580 if {$value eq ""} { 01581 .foldwin.bf.ok configure -state disabled 01582 } else { 01583 .foldwin.bf.ok configure -state normal 01584 } 01585 01586 return 1 01587 01588 } 01589 01590 ###################################################################### 01591 # Opens the given file. 01592 proc handle_open {} { 01593 01594 variable widgets 01595 variable current_server 01596 variable current_dir 01597 variable current_fname 01598 01599 # Get the currently selected item 01600 set selected [$widgets(tl) curselection] 01601 01602 # Get the filename(s) 01603 if {[$widgets(open) cget -text] eq [msgcat::mc "Open"]} { 01604 set current_fname [list] 01605 foreach select $selected { 01606 lappend current_fname [list [$widgets(tl) cellcget $select,fname -text] [$widgets(tl) cellcget $select,dir -text]] 01607 } 01608 } else { 01609 set current_fname [file join $current_dir($current_server) [$widgets(save_entry) get]] 01610 } 01611 01612 # Kill the window 01613 destroy .ftp 01614 01615 } 01616 01617 ###################################################################### 01618 # Cancels the open operation. 01619 proc handle_cancel {} { 01620 01621 variable current_fname 01622 01623 # Indicate that no file was chosen 01624 set current_fname "" 01625 01626 # Close the window 01627 destroy .ftp 01628 01629 } 01630 01631 ###################################################################### 01632 # Adds a new directory to the given table. 01633 proc set_current_directory {directory update_hist} { 01634 01635 variable widgets 01636 variable current_server 01637 variable current_dir 01638 variable dir_hist 01639 variable dir_hist_index 01640 variable connections 01641 01642 # Get the current tablelist cursor 01643 set orig_cursor [$widgets(tl) cget -cursor] 01644 01645 # Set the tablelist cursor to be busy cursor 01646 $widgets(tl) configure -cursor [ttk::cursor busy] 01647 01648 # If the directory is empty, get the current directory 01649 if {$directory eq ""} { 01650 switch [lindex $connections($current_server) 1] { 01651 "FTP" - 01652 "SFTP" { 01653 set directory [::FTP_PWD $current_server] 01654 } 01655 "WebDAV" { 01656 set directory "." 01657 } 01658 } 01659 } 01660 01661 # Add the new directory 01662 set items [list] 01663 if {![dir_contents $current_server $directory items]} { 01664 tk_messageBox -parent .ftp -icon error -type ok -default ok -message [msgcat::mc "Unable to read remote directory contents."] -detail $directory 01665 return 01666 } 01667 01668 # Delete the children of the given parent in the table 01669 $widgets(tl) delete 0 end 01670 01671 # Add the directories first 01672 foreach fname [lsort -index 0 [lsearch -all -inline -index 1 $items 1]] { 01673 set row [$widgets(tl) insert end $fname] 01674 $widgets(tl) cellconfigure $row,fname -image remote_directory 01675 } 01676 01677 # Add the files second 01678 foreach fname [lsort -index 0 [lsearch -all -inline -index 1 $items 0]] { 01679 set row [$widgets(tl) insert end $fname] 01680 $widgets(tl) cellconfigure $row,fname -image remote_file 01681 } 01682 01683 # Reset the tablelist cursor to be busy cursor 01684 $widgets(tl) configure -cursor $orig_cursor 01685 01686 # Sets the current directory to the provided value 01687 set current_dir($current_server) $directory 01688 01689 # Update the state/text of the menubutton 01690 $widgets(dir_mb) configure -text $directory -state normal 01691 01692 # Update the directory history 01693 if {$update_hist} { 01694 catch { set dir_hist($current_server) [lreplace $dir_hist($current_server) [expr $dir_hist_index($current_server) + 1] end] } 01695 lappend dir_hist($current_server) $directory 01696 set dir_hist_index($current_server) [expr [llength $dir_hist($current_server)] - 1] 01697 if {[llength $dir_hist($current_server)] == 1} { 01698 $widgets(dir_back) configure -state disabled -image remote_back_disabled 01699 } else { 01700 $widgets(dir_back) configure -state normal -image remote_back 01701 } 01702 $widgets(dir_forward) configure -state disabled -image remote_next_disabled 01703 } 01704 01705 # Enable the New Folder button 01706 $widgets(folder) configure -state normal 01707 01708 } 01709 01710 ########### 01711 # FTP API # 01712 ########### 01713 01714 ###################################################################### 01715 # Connects to the given FTP server and loads the contents of the given 01716 # start directory into the open dialog table. 01717 # 01718 # Value of type is either ftp or sftp 01719 proc connect {name} { 01720 01721 variable widgets 01722 variable connections 01723 variable opened 01724 01725 if {![info exists connections($name)]} { 01726 return -code error [format "%s (%s)" [msgcat::mc "Connection does not exist"] $name] 01727 } 01728 01729 lassign $connections($name) key type server user passwd port startdir 01730 01731 # Get a password from the user if it is not set 01732 if {$passwd eq ""} { 01733 if {[set passwd [get_password]] eq ""} { 01734 return 0 01735 } 01736 lset connections($name) 3 $passwd 01737 if {[info exists widgets(sb)] && [winfo exists $widgets(sb)]} { 01738 $widgets(sb) cellconfigure $key,passwd -text $passwd 01739 } 01740 } 01741 01742 # Open and initialize the connection 01743 switch $type { 01744 "FTP" - 01745 "SFTP" { 01746 if {[catch { ::FTP_OpenSession $name [expr {($type eq "FTP") ? "" : "s"}] $server:$port $user $passwd $server "" } rc]} { 01747 if {[winfo exists .ftp]} { 01748 tk_messageBox -parent .ftp -type ok -default ok -icon error \ 01749 -message [format "%s $type %s $server" [msgcat::mc "Unable to connect to"] [msgcat::mc "server"]] -detail $rc 01750 } else { 01751 logger::log $rc 01752 } 01753 return 0 01754 } elseif {$startdir ne ""} { 01755 if {[catch { ::FTP_CD $name $startdir } rc]} { 01756 if {[winfo exists .ftp]} { 01757 tk_messageBox -parent .ftp -type ok -default ok -icon error \ 01758 -message [format "%s $type %s $server" [msgcat::mc "Unable to connect to"] [msgcat::mc "server"]] -detail $rc 01759 } else { 01760 logger::log $rc 01761 } 01762 disconnect $name 01763 } elseif {$rc == 1} { 01764 set opened($name) 1 01765 return 1 01766 } else { 01767 return 0 01768 } 01769 } else { 01770 set opened($name) 1 01771 return 1 01772 } 01773 } 01774 "WebDAV" { 01775 if {[catch { webdav::connect $server -username $user -password $passwd } rc]} { 01776 if {[winfo exists .ftp]} { 01777 tk_messageBox -parent .ftp -type ok -default ok -icon error \ 01778 -message [format "%s $type %s $server" [msgcat::mc "Unable to connect to"] [msgcat::mc "server"]] -default $rc 01779 } else { 01780 logger::log $rc 01781 } 01782 return 0 01783 } else { 01784 set opened($name) $rc 01785 return 1 01786 } 01787 } 01788 } 01789 01790 return 0 01791 01792 } 01793 01794 ###################################################################### 01795 # Disconnects from the given FTP server. 01796 proc disconnect {name} { 01797 01798 variable connections 01799 variable opened 01800 variable dir_hist 01801 variable dir_hist_index 01802 variable current_server 01803 01804 switch [lindex $connections($name) 1] { 01805 "FTP" - 01806 "SFTP" { 01807 if {[info exists opened($name)]} { 01808 ::FTP_CloseSession $name 01809 unset opened($name) 01810 } 01811 } 01812 "WebDAV" { 01813 if {[info exists opened($name)]} { 01814 $opened($name) close 01815 unset opened($name) 01816 } 01817 } 01818 } 01819 01820 # Update directory history 01821 if {$name eq $current_server} { 01822 catch { unset dir_hist($current_server) } 01823 catch { unset dir_hist_index($current_server) } 01824 set current_server "" 01825 } 01826 01827 } 01828 01829 ###################################################################### 01830 # Called on application exit. Disconnects all opened connections. 01831 proc disconnect_all {} { 01832 01833 variable opened 01834 01835 foreach name [array names opened] { 01836 disconnect $name 01837 } 01838 01839 } 01840 01841 ###################################################################### 01842 # Returns the matching filename line in the given listing of files within 01843 # a directory. 01844 proc find_fname {listing fname} { 01845 01846 set match_expr [string repeat {\S+\s+} 8] 01847 01848 return [lsearch -inline -regexp $listing "^\s*$match_expr$fname\$"] 01849 01850 } 01851 01852 ###################################################################### 01853 # Returns 1 if the file exists on the server. 01854 proc file_exists {name fname} { 01855 01856 variable connections 01857 variable opened 01858 01859 switch [lindex $connections($name) 1] { 01860 "FTP" - 01861 "SFTP" { 01862 if {![catch { ::FTP_CD $name [file dirname $fname] } rc]} { 01863 if {![catch { ::FTP_List $name 0 } rc]} { 01864 return [expr {[find_fname $rc [file tail $fname]] ne ""}] 01865 } else { 01866 logger::log $rc 01867 } 01868 } else { 01869 logger::log $rc 01870 } 01871 } 01872 "WebDAV" { 01873 if {![catch { $opened($name) getstat [webdav_fname $fname] } rc]} { 01874 return 1 01875 } 01876 } 01877 } 01878 01879 return 0 01880 01881 } 01882 01883 ###################################################################### 01884 # Returns the modification time of the given file on the server. 01885 proc get_mtime {name fname} { 01886 01887 variable connections 01888 variable opened 01889 01890 switch [lindex $connections($name) 1] { 01891 "FTP" - 01892 "SFTP" { 01893 if {![catch { ::FTP_CD $name [file dirname $fname] } rc]} { 01894 if {![catch { ::FTP_List $name 0 } rc]} { 01895 if {[set file_out [find_fname $rc [file tail $fname]]] ne ""} { 01896 return [clock scan [join [lrange $file_out 5 7]]] 01897 } 01898 } else { 01899 logger::log $rc 01900 } 01901 } else { 01902 logger::log $rc 01903 } 01904 } 01905 "WebDAV" { 01906 if {![catch { $opened($name) getstat [webdav_fname $fname] } rc]} { 01907 array set status $rc 01908 return $status(mtime) 01909 } else { 01910 logger::log $rc 01911 } 01912 } 01913 } 01914 01915 return 0 01916 01917 } 01918 01919 ###################################################################### 01920 # Returns a list of two items such that the first list is a listing 01921 # of directories in the given directory and the second list is a listing 01922 # of files in the given directory. 01923 proc dir_contents {name dirname pitems} { 01924 01925 variable connections 01926 variable opened 01927 01928 upvar $pitems items 01929 01930 switch [lindex $connections($name) 1] { 01931 "FTP" - 01932 "SFTP" { 01933 if {![catch { ::FTP_CD $name $dirname } rc]} { 01934 if {![catch { ::FTP_List $name 0 } rc]} { 01935 foreach item $rc { 01936 set fname [file join $dirname [lrange $item 8 end]] 01937 if {[string index [file tail $fname] 0] eq "."} { 01938 continue 01939 } 01940 set dir [expr {[::FTP_IsDir $name $fname] eq $fname}] 01941 lappend items [list $fname $dir] 01942 } 01943 return 1 01944 } else { 01945 logger::log $rc 01946 } 01947 } else { 01948 logger::log $rc 01949 } 01950 } 01951 "WebDAV" { 01952 if {![catch { $opened($name) enumerate [string map {{ } {%20}} $dirname] 1 } rc]} { 01953 foreach {fname status} [lrange $rc 2 end] { 01954 array set stat $status 01955 if {[string index $fname 0] eq "."} { 01956 continue 01957 } 01958 lappend items [list [file join $dirname [string map {{%20} { }} $fname]] [expr {$stat(type) eq "directory"}]] 01959 } 01960 return 1 01961 } else { 01962 logger::log $rc 01963 } 01964 } 01965 } 01966 01967 return 0 01968 01969 } 01970 01971 ###################################################################### 01972 # Get the file contents of the given filename using the given connection 01973 # name if the remote file is newer than the given modtime. Returns 1 01974 # if the file was retrieved without error; otherwise, returns 0. 01975 proc get_file {name fname encode pcontents pmodtime} { 01976 01977 variable connections 01978 variable opened 01979 01980 upvar $pcontents contents 01981 upvar $pmodtime modtime 01982 01983 switch [lindex $connections($name) 1] { 01984 "FTP" - 01985 "SFTP" { 01986 set local [file join $::tke_home sftp_get.tmp] 01987 set modtime [get_mtime $name $fname] 01988 if {![catch { ::FTP_GetFile $name $fname $local 0 } rc]} { 01989 if {![catch { open $local r } rc]} { 01990 fconfigure $rc -encoding $encode 01991 set contents [read $rc] 01992 close $rc 01993 file delete -force $local 01994 return 1 01995 } else { 01996 logger::log $rc 01997 } 01998 } else { 01999 logger::log $rc 02000 } 02001 } 02002 "WebDAV" { 02003 set modtime [get_mtime $name $fname] 02004 if {![catch { $opened($name) get [webdav_fname $fname] } rc]} { 02005 set contents $rc 02006 return 1 02007 } else { 02008 logger::log $rc 02009 } 02010 } 02011 } 02012 02013 return 0 02014 02015 } 02016 02017 ###################################################################### 02018 # Saves the given file contents to the given filename. Returns 1 if 02019 # the file was saved successfully; otherwise, returns 0. 02020 proc save_file {name fname encode contents pmodtime} { 02021 02022 variable connections 02023 variable opened 02024 02025 upvar $pmodtime modtime 02026 02027 switch [lindex $connections($name) 1] { 02028 "FTP" - 02029 "SFTP" { 02030 set local [file join $::tke_home sftp_put.tmp] 02031 if {![catch { open $local w } rc]} { 02032 fconfigure $rc -encoding $encode 02033 puts $rc $contents 02034 close $rc 02035 if {![catch { ::FTP_PutFile $name $local $fname [file size $local] } rc]} { 02036 set modtime [get_mtime $name $fname] 02037 file delete -force $local 02038 return 1 02039 } else { 02040 logger::log $rc 02041 file delete -force $local 02042 } 02043 } else { 02044 logger::log $rc 02045 } 02046 } 02047 "WebDAV" { 02048 if {![catch { $opened($name) put [webdav_fname $fname] $contents } rc]} { 02049 set modtime [get_mtime $name $fname] 02050 return 1 02051 } else { 02052 logger::log $rc 02053 } 02054 } 02055 } 02056 02057 return 0 02058 02059 } 02060 02061 ###################################################################### 02062 # Creates the given directory on the remote end. 02063 proc make_directory {name dirname} { 02064 02065 variable connections 02066 variable opened 02067 02068 # Make the directory remotely 02069 switch [lindex $connections($name) 1] { 02070 "FTP" - 02071 "SFTP" { 02072 if {![catch { ::FTP_MkDir $name $dirname } rc]} { 02073 return 1 02074 } else { 02075 logger::log $rc 02076 } 02077 } 02078 "WebDAV" { 02079 if {![catch { $opened($name) mkdir [webdav_fname $dirname] } rc]} { 02080 return 1 02081 } else { 02082 logger::log $rc 02083 } 02084 } 02085 } 02086 02087 return 0 02088 02089 } 02090 02091 ###################################################################### 02092 # Removes one or more directories on the server. 02093 proc remove_directories {name dirnames args} { 02094 02095 variable connections 02096 variable opened 02097 02098 array set opts { 02099 -force 0 02100 } 02101 array set opts $args 02102 02103 set retval 1 02104 02105 # Delete the list of directories 02106 switch [lindex $connections($name) 1] { 02107 "FTP" - 02108 "SFTP" { 02109 if {$opts(-force)} { 02110 foreach dirname $dirnames { 02111 set items [list] 02112 if {[dir_contents $name $dirname items]} { 02113 foreach item $items { 02114 lassign $item fname isdir 02115 if {$isdir} { 02116 if {![remove_directories $name $fname -force 1]} { 02117 set retval 0 02118 } 02119 } else { 02120 if {![remove_files $name $fname]} { 02121 set retval 0 02122 } 02123 } 02124 } 02125 if {[catch { ::FTP_RmDir $name $dirname } rc]} { 02126 logger::log $rc 02127 set retval 0 02128 } 02129 } 02130 } 02131 } else { 02132 foreach dirname $dirnames { 02133 if {[catch { ::FTP_RmDir $name $dirname } rc]} { 02134 logger::log $rc 02135 set retval 0 02136 } 02137 } 02138 } 02139 } 02140 "WebDAV" { 02141 foreach dirname $dirnames { 02142 if {[catch { $opened($name) delete [webdav_fname $dirname] } rc]} { 02143 logger::log $rc 02144 set retval 0 02145 } 02146 } 02147 } 02148 default { 02149 set retval 0 02150 } 02151 } 02152 02153 return $retval 02154 02155 } 02156 02157 ###################################################################### 02158 # Rename the given file name. 02159 proc rename_file {name curr_fname new_fname} { 02160 02161 variable connections 02162 variable opened 02163 02164 # Change the current directory 02165 switch [lindex $connections($name) 1] { 02166 "FTP" - 02167 "SFTP" { 02168 if {![catch { ::FTP_Rename $name $curr_fname $new_fname } rc]} { 02169 return 1 02170 } else { 02171 logger::log $rc 02172 } 02173 } 02174 "WebDAV" { 02175 if {![catch { $opened($name) copy [webdav_fname $curr_fname] [webdav_fname $new_fname] } rc]} { 02176 if {![catch { $opened($name) delete [webdav_fname $curr_fname] } rc]} { 02177 return 1 02178 } else { 02179 logger::log $rc 02180 } 02181 } else { 02182 logger::log $rc 02183 } 02184 } 02185 } 02186 02187 return 0 02188 02189 } 02190 02191 ###################################################################### 02192 # Duplicates a given filename. 02193 proc duplicate_file {name fname new_fname} { 02194 02195 variable connections 02196 variable contents 02197 variable opened 02198 02199 # Duplicate the file 02200 switch [lindex $connections($name) 1] { 02201 "FTP" - 02202 "SFTP" { 02203 set local [file join $::tke_home sftp_dup.tmp] 02204 if {![catch { ::FTP_GetFile $name $fname $local 0 } rc]} { 02205 if {![catch { ::FTP_PutFile $name $local $new_fname [file size $local] } rc]} { 02206 file delete -force $local 02207 return 1 02208 } else { 02209 logger::log $rc 02210 file delete -force $local 02211 } 02212 } else { 02213 logger::log $rc 02214 } 02215 } 02216 "WebDAV" { 02217 if {![catch { $opened($name) copy [webdav_fname $fname] [webdav_fname $new_fname] } rc]} { 02218 return 1 02219 } else { 02220 logger::log $rc 02221 } 02222 } 02223 } 02224 02225 return 0 02226 02227 } 02228 02229 ###################################################################### 02230 # Removes one or more files on the server. 02231 proc remove_files {name fnames} { 02232 02233 variable connections 02234 variable opened 02235 02236 set retval 1 02237 02238 # Delete the list of directories 02239 switch [lindex $connections($name) 1] { 02240 "FTP" - 02241 "SFTP" { 02242 foreach fname $fnames { 02243 if {[catch { ::FTP_Delete $name $fname } rc]} { 02244 logger::log $rc 02245 set retval 0 02246 } 02247 } 02248 } 02249 "WebDAV" { 02250 foreach fname $fnames { 02251 if {[catch { $opened($name) delete [webdav_fname $fname] } rc]} { 02252 logger::log $rc 02253 set retval 0 02254 } 02255 } 02256 } 02257 default { 02258 set retval 0 02259 } 02260 } 02261 02262 return $retval 02263 02264 } 02265 02266 ###################################################################### 02267 # Loads the FTP connections file. 02268 proc load_connections {} { 02269 02270 variable widgets 02271 variable groups 02272 variable connections 02273 variable opened 02274 variable remote_file 02275 02276 # Clear the connections 02277 array unset connections 02278 02279 # Clear the table 02280 $widgets(sb) delete 0 end 02281 02282 if {![catch { tkedat::read $remote_file 0 } rc]} { 02283 array set data $rc 02284 foreach key [lsort -dictionary [array names data]] { 02285 lassign [split $key ,] num group name 02286 if {![info exists groups($group)]} { 02287 set groups($group) [$widgets(sb) insertchild root end $group] 02288 } 02289 if {[llength $data($key)] >= 7} { 02290 set data($key) [lreplace $data($key) 3 3 [base64::decode [lindex $data($key) 3]]] 02291 set data($key) [lreplace $data($key) 6 6] 02292 } 02293 set row [$widgets(sb) insertchild $groups($group) end [list $name $data($key) [lindex $data($key) 3]]] 02294 set connections($group,$name) [list $row {*}$data($key)] 02295 if {[info exists opened($group,$name)]} { 02296 $widgets(sb) cellconfigure $row,name -image remote_connected 02297 } 02298 } 02299 } 02300 02301 # If the table is empty, make sure that at least one group exists 02302 if {[$widgets(sb) size] == 0} { 02303 set groups(Group) [$widgets(sb) insertchild root end [msgcat::mc "Group"]] 02304 } 02305 02306 } 02307 02308 ###################################################################### 02309 # This is used for BIST purposes only. Loads the stored connections 02310 # into the connections array but does not attempt to store the connection 02311 # information into the UI. 02312 proc quick_load_connections {} { 02313 02314 variable connections 02315 variable remote_file 02316 02317 array unset connections 02318 02319 if {![catch { tkedat::read $remote_file 0 } rc]} { 02320 array set data $rc 02321 foreach key [array names data] { 02322 lassign [split $key ,] num group name 02323 if {[llength $data($key)] >= 7} { 02324 set data($key) [lreplace $data($key) 3 3 [base64::decode [lindex $data($key) 3]]] 02325 set data($key) [lreplace $data($key) 6 6] 02326 } 02327 set connections($group,$name) [list "" {*}$data($key)] 02328 } 02329 } 02330 02331 } 02332 02333 ###################################################################### 02334 # Saves the connections to a file 02335 proc save_connections {} { 02336 02337 variable widgets 02338 variable connections 02339 variable remote_file 02340 02341 array unset connections 02342 02343 # Gather the data to save from the table 02344 set num 0 02345 foreach group_key [$widgets(sb) childkeys root] { 02346 set group [$widgets(sb) cellcget $group_key,name -text] 02347 foreach conn_key [$widgets(sb) childkeys $group_key] { 02348 set name [$widgets(sb) cellcget $conn_key,name -text] 02349 set settings [$widgets(sb) cellcget $conn_key,settings -text] 02350 lappend data "$num,$group,$name" [list {*}[lreplace $settings 3 3 [base64::encode [lindex $settings 3]]] 1] 02351 set connections($group,$name) [list $conn_key {*}[lreplace $settings 3 3 [$widgets(sb) cellcget $conn_key,passwd -text]]] 02352 incr num 02353 } 02354 } 02355 02356 # Write the information to file 02357 catch { tkedat::write $remote_file $data 0 } 02358 02359 } 02360 02361 ###################################################################### 02362 # Returns the list of files in the TKE home directory to copy. 02363 proc get_share_items {dir} { 02364 02365 return [list remote.tkedat] 02366 02367 } 02368 02369 ###################################################################### 02370 # Called whenever the share directory changes. 02371 proc share_changed {dir} { 02372 02373 variable remote_file 02374 02375 set remote_file [file join $dir remote.tkedat] 02376 02377 } 02378 02379 ###################################################################### 02380 # Returns the filename to use for various webdav commands. 02381 proc webdav_fname {fname} { 02382 02383 set file_list [file split $fname] 02384 02385 if {[lindex $file_list 0] eq "."} { 02386 set file_list [lrange $file_list 1 end] 02387 } 02388 02389 return [string map {{ } {%20}} [file join {*}$file_list]] 02390 02391 } 02392 02393 } 02394