lib/gui_script/filesel.tcl

   1
   2 if {![info exists UseNativeDialogs] || $UseNativeDialogs == ""} {
   3   if {$tcl_platform(platform) == "windows"} {
   4     set UseNativeDialogs 1
   5   } else {
   6     set UseNativeDialogs 0
   7   }
   8 }
   9
  10 #----- file selection
  11
  12 set fileselect(toplevel) .fileselect
  13 set fileselect(button)   ""
  14 set fileselect(filter)   *
  15 set fileselect(filename) ""
  16 set fileselect(xpos) -1
  17 set fileselect(ypos) -1
  18 set fileselect(down) [image create bitmap -data "
  19 #define down_width 17
  20 #define down_height 10
  21 static unsigned char down_bits[] = {
  22    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xf8, 0x3f, 0x00, 0xf0, 0x1f, 0x00,
  23    0xe0, 0x0f, 0x00, 0xc0, 0x07, 0x00, 0x80, 0x03, 0x00, 0x00, 0x01, 0x00,
  24    0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"]
  25
  26 proc fileselect {title defname {x -1} {y -1} {filter *}} {
  27   global fileselect
  28   set curdir [pwd]
  29
  30   set top $fileselect(toplevel)
  31   catch {destroy $top}
  32   toplevel $top
  33   wm title $top $title
  34   wm transient $top [winfo toplevel [winfo parent $top]]
  35
  36   #--- buttons
  37
  38   set w [frame $top.button -relief sunken -bd 2]
  39   pack $w -side bottom -fill x -padx 2 -pady 2 -anchor s -expand 1
  40   button $w.accept -relief raised -text Accept \
  41     -command "set fileselect(button) 1"
  42   button $w.cancel -relief raised -text Cancel \
  43     -command "set fileselect(button) 0"
  44   pack $w.accept $w.cancel -side left -expand 1 -fill x -padx 5 -pady 2
  45
  46   $fileselect(down) configure -foreground [$w.accept cget -foreground]
  47
  48   #--- filter entry
  49
  50   set w [frame $top.filter]
  51   pack $w -side top -fill x -padx 2 -pady 2 -anchor n
  52   label $w.label -text "Filter:"
  53   pack $w.label -side left -anchor w
  54   entry $w.entry -relief sunken
  55   pack $w.entry -side left -fill x -expand 1
  56   menubutton $w.menubut -relief raised -image $fileselect(down) \
  57     -menu $w.menubut.m -direction left
  58   menu $w.menubut.m -tearoff 0
  59   pack $w.menubut -side right -fill y
  60
  61   bind $w.entry <Escape> {filesel:entry %W [pwd]/$fileselect(filter)}
  62   bind $w.entry <Return> {
  63     global fileselect
  64     set dir [%W get]
  65     set fileselect(filter) "*"
  66     set fileselect(filename) ""
  67     if {![file isdirectory $dir]} {
  68       set fileselect(filter) [file tail $dir]
  69       set dir [file dirname $dir]
  70     }
  71     catch {cd $dir}
  72     filesel:Select
  73   }
  74   bind $w.entry <Control-u> {%W delete 0 end}
  75
  76   #--- file selection entry
  77
  78   set w [frame $top.filename]
  79   pack $w -side bottom -fill x -padx 2 -pady 2 -anchor s
  80   label $w.label -text "Filename:"
  81   pack $w.label -side left -anchor w
  82   entry $w.entry -relief sunken
  83   pack $w.entry -side left -fill x -expand 1
  84
  85   bind $w.entry <Escape> {filesel:entry %W [pwd]/$fileselect(filename)}
  86   bind $w.entry <Return> {
  87     global fileselect
  88     if [file isdirectory [%W get]] {
  89       set fileselect(filename) ""
  90       catch {cd [%W get]}
  91       filesel:Select
  92     } else {
  93       set fileselect(button) 1
  94     }
  95   }
  96   bind $w.entry <Control-u> {%W delete 0 end}
  97
  98   #--- directory list
  99
 100   set w [frame $top.dirlist]
 101   pack $w -side left -fill both -padx 2 -expand 1
 102   label $w.label -text "Directories:"
 103   pack $w.label -side top -anchor w
 104   scrollbar $w.scroll -relief sunken -command "$w.list yview"
 105   pack $w.scroll -side right -fill y
 106   listbox $w.list -relief sunken -yscroll "$w.scroll set" \
 107     -selectmode browse
 108   pack $w.list -side left -fill both -expand 1
 109
 110   bind $w.list <Double-Button-1> {filesel:Directory %W}
 111   bind $w.list <Return> {filesel:Directory %W}
 112
 113   #--- file list
 114
 115   set w [frame $top.filelist]
 116   pack $w -side left -fill both -padx 2 -expand 1
 117   label $w.label -text "Files:"
 118   pack $w.label -side top -anchor w
 119   scrollbar $w.scroll -relief sunken -command "$w.list yview"
 120   pack $w.scroll -side right -fill y
 121   listbox $w.list -relief sunken -yscroll "$w.scroll set" \
 122     -selectmode browse
 123   pack $w.list -side left -fill both -expand 1
 124
 125   bind $w.list <ButtonRelease-1> {filesel:Filename %W}
 126   bind $w.list <Return> {filesel:Filename %W}
 127   bind $w.list <Double-Button-1> {
 128     global fileselect
 129     if [filesel:Filename %W] {set fileselect(button) 1}
 130   }
 131
 132   #--- initialize
 133
 134   set fileselect(filter) ""
 135   foreach filt $filter {
 136     if {[llength $filt] == 2} {
 137       set extlist {}
 138       foreach ext [lindex $filt 1] {
 139         if {[string index $ext 0] != "*"} {
 140           set e "*$ext"
 141         } else {
 142           set e $ext
 143         }
 144         if {$extlist == ""} {
 145           set extlist $e
 146         } else {
 147           append extlist ",$e"
 148         }
 149       }
 150       $top.filter.menubut.m add command \
 151         -label "[lindex $filt 0] \($extlist\)" \
 152         -command "set fileselect(filter) $extlist; filesel:Select"
 153       if {$fileselect(filter) == ""} {
 154         set fileselect(filter) $extlist
 155       }
 156     }
 157   }
 158   if {$fileselect(filter) == ""} {
 159     $top.filter.menubut configure -state disabled
 160     set fileselect(filter) $filter
 161   }
 162   set fileselect(filename) ""
 163   if {$defname != ""} {
 164     if [file isdirectory $defname] {
 165       catch {cd $defname}
 166     } else {
 167       catch {cd [file dirname $defname]}
 168       if [string match "*\[*?\]*" [file tail $defname]] {
 169         set fileselect(filter) [file tail $defname]
 170       } else {
 171         set fileselect(filename) [file tail $defname]
 172       }
 173     }
 174   }
 175   filesel:Select 0
 176
 177   #--- locate the window
 178
 179   if {$x != "" && [winfo exists $x]} {
 180     center_window $top $x
 181   } else {
 182     wm withdraw $top
 183     update idletasks
 184     set ww [winfo reqwidth  $top]
 185     set wh [winfo reqheight $top]
 186
 187     if {$x < 0} {
 188       if {$fileselect(xpos) < 0} {
 189         if [winfo ismapped .] {
 190           set x [expr [winfo rootx .] + ([winfo width .] - $ww) / 2]
 191         } else {
 192           set x [expr ([winfo screenwidth $top] - $ww) / 2]
 193         }
 194       } else {
 195         set x $fileselect(xpos)
 196       }
 197     } else {
 198       set x [expr $x - $ww / 2]
 199     }
 200     if {$x < 0} {
 201       set pos +0
 202     } elseif {[expr $x + $ww] > [winfo screenwidth $top]} {
 203       set pos -0
 204     } else {
 205       set pos +$x
 206     }
 207
 208     if {$y < 0} {
 209       if {$fileselect(ypos) < 0} {
 210         if [winfo ismapped .] {
 211           set y [expr [winfo rooty .] + ([winfo height .] - $wh) / 2]
 212         } else {
 213           set y [expr ([winfo screenheight $top] - $wh) / 2]
 214         }
 215       } else {
 216         set y $fileselect(ypos)
 217       }
 218     } else {
 219       set y [expr $y - $wh / 2]
 220     }
 221     if {$y < 0} {
 222       set pos $pos+0
 223     } elseif {[expr $y + $wh] > [winfo screenheight $top]} {
 224       set pos $pos-0
 225     } else {
 226       set pos $pos+$y
 227     }
 228
 229     wm geom $top $pos
 230     wm deiconify $top
 231   }
 232
 233   #--- wait for button click
 234
 235   set oldFocus [focus]
 236   set oldGrab [grab current $w]
 237   if {$oldGrab != ""} {
 238     set grabStatus [grab status $oldGrab]
 239   }
 240   grab $top
 241   $top.filename.entry selection range 0 end
 242   focus $top.filename.entry
 243   tkwait variable fileselect(button)
 244   if $fileselect(button) {
 245     set filename [$top.filename.entry get]
 246   } else {
 247     set filename ""
 248   }
 249   set fileselect(xpos) [winfo rootx $top]
 250   set fileselect(ypos) [winfo rooty $top]
 251   destroy $top
 252   catch {focus $oldFocus}
 253   if {$oldGrab != ""} {
 254     if {$grabStatus == "global"} {
 255       grab -global $oldGrab
 256     } else {
 257       grab $oldGrab
 258     }
 259   }
 260   catch {cd $curdir}
 261   return $filename
 262 }
 263
 264 proc filesel:Directory {w} {
 265   global fileselect
 266   if {[$w curselection] != ""} {
 267     set dir [$w get [$w curselection]]
 268     if {$dir == ".. <up>"} {
 269       set dir ".."
 270     }
 271     catch {cd $dir}
 272     if {$fileselect(filename) != "" &&
 273       ![file isfile $fileselect(filename)]} {
 274       set fileselect(filename) ""
 275     }
 276     filesel:Select
 277   }
 278 }
 279
 280 proc filesel:Filename {w} {
 281   global fileselect
 282   if {[$w curselection] != ""} {
 283     set fileselect(filename) [$w get [$w curselection]]
 284     filesel:entry $fileselect(toplevel).filename.entry \
 285       [pwd]/$fileselect(filename)
 286     return 1
 287   }
 288   return 0
 289 }
 290
 291 proc filesel:Select {{vis 1}} {
 292   global fileselect tcl_platform
 293   set curdir [pwd]
 294   if {[info exists tcl_platform(platform)] &&
 295     $tcl_platform(platform) == "windows" &&
 296     [string index $curdir 1] == ":"} {
 297     set curdir [string range $curdir 2 end]
 298   }
 299   if $vis {
 300     $fileselect(toplevel) configure -cursor watch
 301     update idletasks
 302   }
 303
 304   #--- fill in directories
 305
 306   set w $fileselect(toplevel).dirlist.list
 307   catch {set files [lsort [glob -nocomplain *]]}
 308   $w delete 0 end
 309   if {$curdir != "/"} {
 310     $w insert 0 ".. <up>"
 311   }
 312   foreach f $files {
 313     if [file isdirectory "./$f"] {
 314       $w insert end $f
 315     }
 316   }
 317
 318   #--- fill in files
 319
 320   set w $fileselect(toplevel).filelist.list
 321   catch {set files [lsort [eval glob -nocomplain \
 322     [split $fileselect(filter) ,]]]}
 323   $w delete 0 end
 324   set n 0
 325   foreach f $files {
 326     if [file isfile "./$f"] {
 327       $w insert end $f
 328       if {$f == $fileselect(filename)} {
 329           $w selection set $n
 330       }
 331       incr n 1
 332     }
 333   }
 334
 335   #--- update filter and filename entries
 336
 337   if {$curdir == "/"} {
 338     filesel:entry $fileselect(toplevel).filter.entry \
 339       [pwd]$fileselect(filter)
 340     filesel:entry $fileselect(toplevel).filename.entry \
 341       [pwd]$fileselect(filename)
 342   } else {
 343     filesel:entry $fileselect(toplevel).filter.entry \
 344       [pwd]/$fileselect(filter)
 345     filesel:entry $fileselect(toplevel).filename.entry \
 346       [pwd]/$fileselect(filename)
 347   }
 348   if $vis {
 349     $fileselect(toplevel) configure -cursor {}
 350   }
 351 }
 352
 353 proc filesel:entry {w s} {
 354   $w delete 0 end
 355   if {$s != ""} {
 356     $w insert insert $s
 357     set c [$w index insert]
 358     if {($c < [$w index @0]) || ($c > [$w index @[winfo width $w]])} {
 359         $w xview $c
 360     }
 361   }
 362 }
 363
 364 #----- directory selection
 365
 366 proc dirselect {title defname {x -1} {y -1}} {
 367   global fileselect
 368   set curdir [pwd]
 369
 370   set top $fileselect(toplevel)
 371   catch {destroy $top}
 372   toplevel $top
 373   wm title $top $title
 374   wm transient $top [winfo toplevel [winfo parent $top]]
 375
 376   #--- filter entry
 377
 378   set w [frame $top.filter]
 379   pack $w -side top -fill x -padx 2 -pady 2 -anchor n
 380   label $w.label -text "Filter:"
 381   pack $w.label -side left -anchor w
 382   entry $w.entry -relief sunken
 383   pack $w.entry -side left -fill x -expand 1
 384
 385   bind $w.entry <Escape> {filesel:entry %W [pwd]/$fileselect(filter)}
 386   bind $w.entry <Return> {
 387     global fileselect
 388     set dir [%W get]
 389     set fileselect(filter) "*"
 390     set fileselect(filename) ""
 391     if {![file isdirectory $dir]} {
 392       set fileselect(filter) [file tail $dir]
 393       set dir [file dirname $dir]
 394     }
 395     catch {cd $dir}
 396     filesel:Select
 397   }
 398   bind $w.entry <Control-u> {%W delete 0 end}
 399
 400   #--- buttons
 401
 402   set w [frame $top.button -relief sunken -bd 2]
 403   pack $w -side bottom -fill x -padx 2 -pady 2 -anchor s -expand 1
 404   button $w.accept -relief raised -text Accept \
 405     -command "set fileselect(button) 1"
 406   button $w.cancel -relief raised -text Cancel \
 407     -command "set fileselect(button) 0"
 408   pack $w.accept $w.cancel -side left -expand 1 -fill x -padx 5 -pady 2
 409
 410   #--- file selection entry
 411
 412   set w [frame $top.filename]
 413   pack $w -side bottom -fill x -padx 2 -pady 2 -anchor s
 414   label $w.label -text "Directory:"
 415   pack $w.label -side left -anchor w
 416   entry $w.entry -relief sunken
 417   pack $w.entry -side left -fill x -expand 1
 418
 419   bind $w.entry <Escape> {filesel:entry %W [pwd]/}
 420   bind $w.entry <Return> {
 421     global fileselect
 422     if [file isdirectory [%W get]] {
 423       set fileselect(button) 1
 424     }
 425   }
 426   bind $w.entry <Control-u> {%W delete 0 end}
 427
 428   #--- directory list
 429
 430   set w [frame $top.dirlist]
 431   pack $w -side left -fill both -padx 2 -expand 1
 432   label $w.label -text "Directories:"
 433   pack $w.label -side top -anchor w
 434   scrollbar $w.scroll -relief sunken -command "$w.list yview"
 435   pack $w.scroll -side right -fill y
 436   listbox $w.list -relief sunken -yscroll "$w.scroll set" \
 437     -selectmode browse -exportselection 0
 438   pack $w.list -side left -fill both -expand 1
 439
 440   bind $w.list <Double-Button-1> {filesel:Directory %W}
 441   bind $w.list <Return> {filesel:Directory %W}
 442
 443   #--- file list
 444
 445   set fg [$top.button.accept cget -disabledforeground]
 446   set bg [$w.list cget -bg]
 447   if {[winfo rgb $w.list $fg] == [winfo rgb $w.list $bg]} {
 448     set fg [$w.list cget -fg]
 449   }
 450   set w [frame $top.filelist]
 451   pack $w -side left -fill both -padx 2 -expand 1
 452   label $w.label -text "Files:"
 453   pack $w.label -side top -anchor w
 454   scrollbar $w.scroll -relief sunken -command "$w.list yview"
 455   pack $w.scroll -side right -fill y
 456   listbox $w.list -relief sunken -yscroll "$w.scroll set" \
 457     -fg $fg -bg $bg -selectforeground $fg -selectbackground $bg \
 458     -selectborderwidth 0 -takefocus 0 -highlightthickness 0
 459   pack $w.list -side left -fill both -expand 1
 460
 461   bind $w.list <Button-1> {}
 462   bind $w.list <Double-Button-1> {}
 463
 464   #--- initialize
 465
 466   set fileselect(filter)   "*"
 467   set fileselect(filename) ""
 468   if {$defname != ""} {
 469     if [file isdirectory $defname] {
 470       catch {cd $defname}
 471     } else {
 472       catch {cd [file dirname $defname]}
 473       if [string match "*\[*?\]*" [file tail $defname]] {
 474         set fileselect(filter) [file tail $defname]
 475       }
 476     }
 477   }
 478   filesel:Select 0
 479
 480   #--- locate the window
 481
 482   if {$x != "" && [winfo exists $x]} {
 483     center_window $top $x
 484   } else {
 485     wm withdraw $top
 486     update idletasks
 487     set ww [winfo reqwidth  $top]
 488     set wh [winfo reqheight $top]
 489
 490     if {$x < 0} {
 491       if {$fileselect(xpos) < 0} {
 492         if [winfo ismapped .] {
 493           set x [expr [winfo rootx .] + ([winfo width .] - $ww) / 2]
 494         } else {
 495           set x [expr ([winfo screenwidth $top] - $ww) / 2]
 496         }
 497       } else {
 498         set x $fileselect(xpos)
 499       }
 500     } else {
 501       set x [expr $x - $ww / 2]
 502     }
 503     if {$x < 0} {
 504       set pos +0
 505     } elseif {[expr $x + $ww] > [winfo screenwidth $top]} {
 506       set pos -0
 507     } else {
 508       set pos +$x
 509     }
 510
 511     if {$y < 0} {
 512       if {$fileselect(ypos) < 0} {
 513         if [winfo ismapped .] {
 514           set y [expr [winfo rooty .] + ([winfo height .] - $wh) / 2]
 515         } else {
 516           set y [expr ([winfo screenheight $top] - $wh) / 2]
 517         }
 518       } else {
 519         set y $fileselect(ypos)
 520       }
 521     } else {
 522       set y [expr $y - $wh / 2]
 523     }
 524     if {$y < 0} {
 525       set pos $pos+0
 526     } elseif {[expr $y + $wh] > [winfo screenheight $top]} {
 527       set pos $pos-0
 528     } else {
 529       set pos $pos+$y
 530     }
 531
 532     wm geom $top $pos
 533     wm deiconify $top
 534   }
 535
 536   #--- wait for button click
 537
 538   set oldFocus [focus]
 539   set oldGrab [grab current $top]
 540   if {$oldGrab != ""} {
 541     set grabStatus [grab status $oldGrab]
 542   }
 543   grab $top
 544   $top.filter.entry selection range 0 end
 545   focus -force $top.filter.entry
 546   tkwait variable fileselect(button)
 547   if $fileselect(button) {
 548     set dirname [$top.filename.entry get]
 549     if ![catch {cd $dirname}] {
 550       set dirname [pwd]
 551     }
 552   } else {
 553     set dirname ""
 554   }
 555   set fileselect(xpos) [winfo rootx $top]
 556   set fileselect(ypos) [winfo rooty $top]
 557   destroy $top
 558   catch {focus $oldFocus}
 559   if {$oldGrab != ""} {
 560     if {$grabStatus == "global"} {
 561       grab -global $oldGrab
 562     } else {
 563       grab $oldGrab
 564     }
 565   }
 566   catch {cd $curdir}
 567   return $dirname
 568 }
 569
 570 proc FileOpen {title defname {wref .} {types ""}} {
 571   global UseNativeDialogs
 572   if {$defname == ""} {
 573     set dir [pwd]
 574     set file ""
 575   } else {
 576     if [file isdirectory $defname] {
 577       set dir $defname
 578       set file ""
 579     } else {
 580       set dir [file dirname $defname]
 581       set file [file tail $defname]
 582     }
 583     if {$dir == "."} {
 584       set dir [pwd]
 585     }
 586   }
 587   if $UseNativeDialogs {
 588     set opts "-title {$title} -initialdir {$dir}"
 589     if {$defname != "" && [file exists $defname]} {
 590       append opts " -initialfile {[file tail $defname]}"
 591     }
 592     if {$file != ""} {
 593       append opts " -initialfile {$file}"
 594     }
 595     if {$wref != "" && [winfo exists $wref]} {
 596       append opts " -parent $wref"
 597     }
 598     if {$types != ""} {
 599       append opts " -filetypes {$types}"
 600     }
 601     return [eval tk_getOpenFile $opts]
 602   }
 603   if {$types == ""} {
 604     set types *
 605   }
 606   while 1 {
 607     set fname [fileselect $title $dir/$file $wref {} $types]
 608     if {$fname == "" || [file exists $fname]} {return $fname}
 609     dialog .fileopen $wref {} $title "$fname
 610 Cannot find this file. Please verify the path and filename." info 0 Ok
 611   }
 612 }
 613
 614 proc FileSave {title defname {wref .} {types ""} {defext ""}} {
 615   global UseNativeDialogs
 616   if {$defname == ""} {
 617     set dir [pwd]
 618     set file ""
 619   } else {
 620     if [file isdirectory $defname] {
 621       set dir $defname
 622       set file ""
 623     } else {
 624       set dir [file dirname $defname]
 625       set file [file tail $defname]
 626     }
 627     if {$dir == "."} {
 628       set dir [pwd]
 629     }
 630   }
 631   if $UseNativeDialogs {
 632     set opts "-title {$title} -initialdir {$dir}"
 633     if {$file != ""} {
 634       append opts " -initialfile {$file}"
 635     }
 636     if {$wref != "" && [winfo exists $wref]} {
 637       append opts " -parent $wref"
 638     }
 639     if {$types != ""} {
 640       append opts " -filetypes {$types}"
 641     }
 642     if {$defext != ""} {
 643       append opts " -defaultextension $defext"
 644     }
 645     return [eval tk_getSaveFile $opts]
 646   }
 647   if {$types == ""} {
 648     set types *
 649   }
 650   while 1 {
 651     set fname [fileselect $title $dir/$file $wref {} $types]
 652     if {$fname == ""} {return ""}
 653     if {$defext != "" && [file extension $fname] == ""} {
 654       append fname ".$defext"
 655     }
 656     if {![file exists $fname]} {return $fname}
 657     if ![dialog .filesave $wref {} $title "$fname
 658 This file already exists. Replace the existing file ?" info 0 Yes No] {
 659       return $fname
 660     }
 661   }
 662 }
 663
 664 proc GetDirectory {title dir {wref .}} {
 665   global UseNativeDialogs
 666   if {$dir == "" || $dir == "." || ![file isdirectory $dir]} {
 667     set dir [pwd]
 668   }
 669   if {$UseNativeDialogs} {
 670     set opts "-title {$title} -initialdir {$dir}"
 671     if {$wref != "" && [winfo exists $wref]} {
 672       append opts " -parent $wref"
 673     }
 674     return [eval tk_getDirectory $opts]
 675   }
 676   return [dirselect $title $dir $wref]
 677 }
 678
 679 proc TempName {{prefix ""} {extlist {}}} {
 680   if {$prefix == ""} {set prefix temp}
 681   set name $prefix
 682   foreach ext $extlist {
 683     if {[file exists $name.$ext]} {
 684       set name ""
 685       break
 686     }
 687   }
 688   if {$name != ""} {return $name}
 689   for {set n 0} {$n < 1000} {incr n} {
 690     set name [format "$prefix%3.3d" $n]
 691     if {[file exists $name]} continue
 692     foreach ext $extlist {
 693       if {[file exists $name.$ext]} {
 694         set name ""
 695         break
 696       }
 697     }
 698     if {$name != ""} {return $name}
 699   }
 700   return ""
 701 }
 702