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
