1############################################################################### 2############################################################################### 3##### Dialogos.tcl 4############################################################################### 5############################################################################### 6##### The contents of this file are adapted from an example in Brent Welch's 7##### book "Practical Programming in Tcl/Tk". I made the changes without 8##### knowing very well what I was doing, so please, don't blame him for all 9##### the weirdness. 10############################################################################### 11##### Copyright 1999-2008 Brent Welch - Andres Garcia. fandom@telefonica.net 12##### The contents of this file are distributed under the terms of the LGPL 13############################################################################### 14 15namespace eval Dialogos { 16 17set ext $::getleftState(imgExt) 18 19set imaArr [image create photo \ 20 -file [file join "$dirGetleft(icons)" arriba.$ext]] 21set imaNew [image create photo \ 22 -file [file join "$dirGetleft(icons)" nuevo.$ext]] 23 24############################################################################### 25# SelectDirNative 26# Does the work by using a Windows or Mac dialog 27# 28# Parameters: 29# initialDir: The directory in which the dialog will open itself. 30# parent: The window over which it will appear. 31# 32# Returns: 33# The chosen path or an empty string if the user cancels. 34# 35# Side effects: 36# If you select a non-existing directory, it will be created for you. 37############################################################################### 38proc SelectDirNative {initialDir parent} { 39 global labelTitles labelMessages indexButtons 40 41 set chosenDir [tk_chooseDirectory -title $labelTitles(directory) \ 42 -parent $parent -initialdir $initialDir] 43 44 if {$chosenDir==""} return 45 46 if {![file exist $chosenDir]} { 47 set what [Dialogos::Dialogo $parent.question -icon question -type yesno \ 48 -message $labelMessages(unknown) -title $labelTitles(unknown)] 49 if {$what=="no"} { 50 set initialDir $chosenDir 51 while {![file exists $initialDir]} { 52 set initialDir [file dirname $initialDir] 53 } 54 return [SelectDirWindows $initialDir $parent] 55 } 56 file mkdir $chosenDir 57 } 58 return $chosenDir 59} 60 61############################################################################### 62# SelectDirectory 63# Opens a dialog window which allows the user to choose one directory. If 64# needed, the directory is created. 65# 66# Parameter: 67# initialDir: directory where the dialog should open itself. 68# parent: the parent window of the dialog, it defaults to the main 69# window of the app. 70# 71# Returns 72# The full path of the chosen directory. 73############################################################################### 74proc SelectDirectory {{initialDir {} } {parent {.} } } { 75 variable fileselect 76 global tcl_patchLevel getleftState 77 global dirGetleft getleftOptions labelMenus indexButtons 78 global env labelButtons labelTitles labelDialogs labelMessages 79 80 if {$getleftState(os)!="unix"} { 81 return [SelectDirNative $initialDir $parent] 82 } 83 84 catch {destroy .fileselect} 85 set win [toplevel .fileselect] 86 87 set coord(x) [winfo rootx $parent] 88 set coord(y) [winfo rooty $parent] 89 90 wm title $win $labelTitles(directory) 91 wm resizable $win 0 0 92 wm geometry $win +[expr {$coord(x)+100}]+[expr {$coord(y)+15}] 93 94 set extFrame [ttk::frame $win.t] 95 96 set topFrame [ttk::frame $extFrame.top] 97 set labelCurrent [ttk::label $topFrame.labelCurrent \ 98 -text "$labelDialogs(current): "] 99 set fileselect(dirEnt) [ttk::label $topFrame.entry -relief sunken -width 35\ 100 -anchor w] 101 102 set upDir [ttk::button $topFrame.up -image $::Dialogos::imaArr -command { 103 Dialogos::fileselectList [file dirname $Dialogos::fileselect(dir)] 104 Dialogos::fileselectOK 105 } -style Toolbutton] 106 set newDir [ttk::button $topFrame.new -image $::Dialogos::imaNew -command { 107 ::Dialogos::NewDir 108 } -style Toolbutton] 109 110 BalloonHelp::set_balloon $upDir $labelMessages(up) 111 BalloonHelp::set_balloon $newDir $labelMessages(newDir) 112 113 set centFrame [ttk::frame $extFrame.central] 114 set fileselect(dirList) [listbox $centFrame.list \ 115 -yscrollcommand [list $centFrame.scroll set] \ 116 -bg $getleftOptions(bg) -fg $getleftOptions(fg) -height 10 117 ] 118 119 set lbFont [$fileselect(dirList) cget -font] 120 regsub {bold} $lbFont {} lbFont 121 $fileselect(dirList) configure -font $lbFont 122 123 set fileselect(scroll) [ttk::scrollbar $centFrame.scroll -command [ 124 list $fileselect(dirList) yview 125 ]] 126 127 set botFrame [ttk::frame $extFrame.bottonFrame] 128 set labelDir [ttk::label $botFrame.labelDir -text "$labelDialogs(dir): "] 129 set fileselect(pathEnt) [ttk::entry $botFrame.dirEntry \ 130 -width 27 -textvariable Dialogos::fileselect(path)] 131 menuEntry::menuEntry $fileselect(pathEnt) 132 133 # Set up bindings to invoke OK and Cancel 134 bind $fileselect(pathEnt) <Return> { 135 if {[Dialogos::fileselectOK]==1} { 136 set Dialogos::fileselect(done) 1 137 } 138 } 139 bind $fileselect(pathEnt) <Control-c> Dialogos::fileselectCancel 140 focus $fileselect(pathEnt) 141 142 set accept [ttk::button $botFrame.ok -width 10 \ 143 -textvariable labelButtons(select) -underline $indexButtons(select)\ 144 -command { 145 if {[Dialogos::fileselectOK]==1} { 146 set Dialogos::fileselect(done) 1 147 } 148 } 149 ] 150 151 set cancel [ttk::button $botFrame.cancel -width 10 \ 152 -textvariable labelButtons(cancel) -underline $indexButtons(cancel)\ 153 -command {set Dialogos::fileselect(done) 0} 154 ] 155 156 wm protocol $win WM_DELETE_WINDOW "$cancel invoke" 157 158 if {$::tcl_version>=8.5} { 159 grid anchor $extFrame c 160 } 161 162 pack $extFrame -fill x -fill y -expand true -ipadx 4 -ipady 4 163 164 grid $topFrame -sticky ew 165 grid $labelCurrent $fileselect(dirEnt) -sticky e 166 grid $upDir -row 0 -column 2 -padx 5 167 grid $newDir -row 0 -column 3 168 169 grid $centFrame -sticky ew -pady 5 170 grid $fileselect(dirList) -sticky news -row 0 -column 0 -pady 2 171 grid $fileselect(scroll) -sticky nsw -row 0 -column 1 -pady 2 172 grid columnconfigure $centFrame 0 -weight 1 173 174 grid $botFrame -sticky ew 175 grid $labelDir -sticky w -row 0 -column 0 176 grid $fileselect(pathEnt) -sticky ew -row 0 -column 1 -padx 4 177 grid $accept -sticky e -row 0 -column 2 178 grid $cancel -sticky e -row 1 -column 2 179 grid columnconfigure $botFrame 1 -weight 1 180 181 # A single click to listbox so the user can use arrow keys 182 bind $fileselect(pathEnt) <Tab> "focus $fileselect(dirList) ; list select set 0 ; break" 183 bind $fileselect(dirList) <Return> "Dialogos::fileselectTmp ; break" 184 bind $fileselect(dirList) <KP_Enter> "Dialogos::fileselectTmp ; break" 185 bind $fileselect(dirList) <space> "Dialogos::fileselectTake ; break" 186 bind $fileselect(dirList) <Tab> "focus $accept ; break" 187 bind $fileselect(dirList) <Button-1> {focus %W} 188 bind $fileselect(dirList) <Double-Button-1> {Dialogos::fileselectTmp ; break } 189 bind $extFrame <KeyPress-Prior> "$fileselect(dirList) yview scroll -1 pages;break" 190 bind $extFrame <KeyPress-Next> "$fileselect(dirList) yview scroll 1 pages;break" 191 bind $accept <Tab> "focus $cancel ; break" 192 bind $cancel <Tab> "focus $fileselect(pathEnt) ; break" 193 bind $win <Escape> "$cancel invoke" 194 195 # Inicializar las variables 196 197 set fileselect(path) {} 198 if {($initialDir!="")&&([file exists $initialDir])} { 199 set dir $initialDir 200 } else { 201 set dir $env(HOME) 202 } 203 204 set fileselect(dir) {} 205 set fileselect(done) 0 206 207 # Wait for the listbox to be visible so 208 # we can provide feedback during the listing 209 tkwait visibility $fileselect(dirList) 210 fileselectList $dir 211 212 grab $win 213 tkwait variable Dialogos::fileselect(done) 214 grab release $win 215 216 destroy $win 217 update 218 if {$fileselect(done)==1} { 219 return $fileselect(path) 220 } 221 return 222} 223 224############################################################################### 225# NewDir 226# Opens a dialog box to create a new directory. 227############################################################################### 228proc NewDir {} { 229 variable fileselect 230 global labelTitles labelButtons getleftOptions 231 variable done 232 233 set coord(x) [winfo rootx .fileselect] 234 set coord(y) [winfo rooty .fileselect] 235 236 set dialog [toplevel .dialog] 237 wm title $dialog $labelTitles(newDir) 238 wm resizable $dialog 0 0 239 wm geometry $dialog +[expr {$coord(x)+100}]+[expr {$coord(y)+15}] 240 241 set done 0 242 243 set marcoEx [ttk::frame $dialog.marcoEx] 244 set marco [ttk::frame $marcoEx.marco -relief groove] 245 set marcoIn [ttk::frame $marco.marcoIn] 246 set dirEnt [ttk::entry $marcoIn.dirent -width 25] 247 248 set botones [ttk::frame $dialog.botones] 249 set aceptar [ttk::button $botones.aceptar -textvariable labelButtons(ok) \ 250 -width 8 -command {set Dialogos::done 1}] 251 set cancelar [ttk::button $botones.cancelar -textvariable labelButtons(cancel) \ 252 -width 8 -command {set Dialogos::done 0}] 253 254 pack $cancelar -side right -padx 9 -pady 5 255 pack $aceptar -side right -pady 5 256 pack $botones -side bottom -fill x 257 258 pack $dirEnt 259 pack $marcoIn -padx 10 -pady 10 260 pack $marco -side bottom 261 pack $marcoEx -ipadx 10 -ipady 5 262 263 bind $dialog <Escape> "$cancelar invoke" 264 bind $dialog <Return> "$aceptar invoke" 265 266 focus $dirEnt 267 grab $dialog 268 tkwait variable Dialogos::done 269 270 if {$done==1} { 271 set dir [$dirEnt get] 272 if {$dir!=""} { 273 if {[catch {file mkdir [file join $fileselect(dir) $dir]} error]} { 274 Dialogos::Dialogo .error -title $labelTitles(error) -icon error \ 275 -message $error 276 } else { 277 Dialogos::fileselectList $fileselect(dir) 278 } 279 } 280 } 281 grab release $dialog 282 destroy $dialog 283 return 284} 285 286############################################################################### 287# fileselectList 288# Puts into the dialog box the directories found in the current one. 289# 290# Parameter 291# dir: Current directory. 292############################################################################## 293proc fileselectList {dir} { 294 variable fileselect 295 global labelTitles labelMessages 296 297 # Update directory 298 $fileselect(dirEnt) configure -text [file nativename $dir] 299 300 # Give the user some feedback 301 set fileselect(dir) $dir 302 $fileselect(dirList) delete 0 end 303 $fileselect(dirList) insert 0 Searching... 304 update idletasks 305 306 $fileselect(dirList) delete 0 307 308 # Add father directory and scan the current one 309 if {!([regexp {^((.:)?(/))$} $fileselect(dir)])} { 310 $fileselect(dirList) insert end .. 311 } else { 312 $fileselect(dirList) insert end / 313 } 314 if {[catch {glob -nocomplain $fileselect(dir)/*/} ficheros]} { 315 Dialogos::Dialogo .fileselect.error -type ok -icon error \ 316 -message $labelMessages(noReadDir) \ 317 -title $labelTitles(error) 318 fileselectList [file dirname $dir] 319 return 320 } 321 322 # Show results 323 foreach f [lsort -dictionary $ficheros] { 324 $fileselect(dirList) insert end [file tail $f] 325 } 326 return 327} 328 329############################################################################### 330# fileselectOk 331# This procedure is invoked when a directory is selected, if needed it asks 332# whether the user wants to create it. 333############################################################################## 334proc fileselectOK { } { 335 variable fileselect 336 global labelTitles labelMessages 337 338 if {$fileselect(path)==""} { 339 fileselectTake 340 if {$fileselect(path)==""} return 341 if {[fileselectOK]==1} { 342 set fileselect(done) 1 343 } 344 return 345 } 346 347 # El directorio padre tiene tratamiento especial 348 if {[regexp {\.\./?} $fileselect(path)]} { 349 set fileselect(path) {} 350 fileselectList [file dirname $fileselect(dir)] 351 return 352 } 353 354 set path [file join $fileselect(dir) $fileselect(path)] 355 356 if {![file exists $path]} { 357 set decision [Dialogos::Dialogo .fileselect.question -icon question \ 358 -message $labelMessages(unknown) -title $labelTitles(unknown) \ 359 -type yesno] 360 switch $decision { 361 yes { 362 file mkdir $path 363 set fileselect(path) $path 364 set fileselect(done) 1 365 return 366 } 367 no return 368 } 369 } 370 if {![file writable $path]} { 371 Dialogos::Dialogo .fileselect.error -type ok -icon error \ 372 -message $labelMessages(noWrite) -title $labelTitles(error) 373 set fileselect(path) "" 374 return 375 } 376 if {[file isdirectory $path]} { 377 set fileselect(done) 1 378 set fileselect(path) $path 379 } 380 return 381} 382 383############################################################################### 384# fileselectCancel 385# Procedure to cancel the selection 386############################################################################## 387proc fileselectCancel {} { 388 variable fileselect 389 390 set fileselect(done) 1 391 set fileselect(path) {} 392 393 return 394} 395 396############################################################################### 397# fileselectClick 398# Select the clicked item in the directory list. 399# 400# Parameter 401# y: point where the user clicked. 402############################################################################## 403proc fileselectClick { y } { 404 variable fileselect 405 406 set fileselect(path) [$fileselect(dirList) get [$fileselect(dirList) nearest $Y]] 407 focus $fileselect(pathEnt) 408 409 return 410} 411 412############################################################################### 413# fileselectTake 414# Takes the selected item from the directory list and puts it in the 415# path entry. 416############################################################################## 417proc fileselectTake {} { 418 variable fileselect 419 420 set seleccion [$fileselect(dirList) curselection] 421 if {$seleccion!=""} { 422 set fileselect(path) [$fileselect(dirList) get $seleccion] 423 } 424 focus $fileselect(pathEnt) 425 426 return 427} 428 429############################################################################### 430# fileselectTmp 431# Invoked when the user doubleclicks on an item in the directory list, 432# takes the directory and makes it the current one. 433############################################################################## 434proc fileselectTmp {} { 435 variable fileselect 436 437 fileselectTake 438 if {[string match \.\. $fileselect(path)] } { 439 fileselectList [file dirname $fileselect(dir)] 440 } else { 441 fileselectList [file join $fileselect(dir) $fileselect(path)] 442 } 443 set fileselect(path) "" 444 445 return 446} 447 448################################################################################ 449# DialogCallback 450# The tile dialog require a callback to process the pressed button, this is 451# it 452# 453# Parameter 454# button: The pressed button. 455# 456# Side effect 457# Puts in Dialogos::pressedButton the right value 458################################################################################ 459proc DialogCallback {button} { 460 variable pressedButton 461 462 set pressedButton $button 463 464 return 465} 466 467################################################################################ 468# Dialogo 469# Invokes the tile dialog button in Unix, and Tk's one in Mac and Win. 470# It tries to be an "almost" drop-in replacement for tk_messageBox. 471# 472# Parameters 473# args: The pameters to pass to the real dialog command. 474# 475# Returns: 476# The pressed button. 477################################################################################ 478proc Dialogo {args} { 479 variable pressedButton 480 global getleftState 481 482 # Used to be Tile had a dialog command 483 if {($getleftState(os)!="unix")||([info commands ::ttk::dialog] eq "")} { 484 set parent [lrange $args 0 0] 485 regexp {(.+)(\.)} $parent nada parent 486 if {![winfo exists $parent]} { 487 set parent . 488 } 489 regsub [lrange $args 0 0] {.*?$} parent {} 490 return [eval tk_messageBox [lrange $args 1 end] -parent $parent] 491 } 492 493 set path [lindex $args 0] 494 regsub {\.\.} $path {.} path 495 496 eval ttk::dialog $path [lrange $args 1 end] \ 497 -command Dialogos::DialogCallback 498 tkwait variable Dialogos::pressedButton 499 500 return $pressedButton 501} 502 503} 504