1# BEGIN LICENSE BLOCK 2# Version: CMPL 1.1 3# 4# The contents of this file are subject to the Cisco-style Mozilla Public 5# License Version 1.1 (the "License"); you may not use this file except 6# in compliance with the License. You may obtain a copy of the License 7# at www.eclipse-clp.org/license. 8# 9# Software distributed under the License is distributed on an "AS IS" 10# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See 11# the License for the specific language governing rights and limitations 12# under the License. 13# 14# The Original Code is The ECLiPSe Constraint Logic Programming System. 15# The Initial Developer of the Original Code is Cisco Systems, Inc. 16# Portions created by the Initial Developer are 17# Copyright (C) 2006 Cisco Systems, Inc. All Rights Reserved. 18# 19# Contributor(s): Daniel Roche, <dan@bigfoot.com> 20# 21# END LICENSE BLOCK 22 23######################################################### 24# Directory Selector TCL version 1.1 25# 26# Daniel Roche, <dan@lectra.com> 27# 28# Modified by Kish Shen, 18 Feb. 1999: changed code so 29# that clicking OK with no selection selects current dir. 30# fixed pwd problem -- returned directory is always cwd 31# behaves properly if browser window killed 32######################################################### 33 34package provide tkgetdir 1.1 35 36######################################################### 37# 38# tk_getDirectory [option value ...] 39# 40# options are : 41# [-initialdir dir] display in dir 42# [-title string] make string title of dialog window 43# [-ok string] make string the label of OK button 44# [-open string] make string the label of OPEN button 45# [-cancel string] make string the label of CANCEL button 46# [-msg1 string] make string the label of the first directory message 47# [-msg2 string] make string the label of the second directory message 48# 49######################################################### 50 51proc tk_getDirectory {args} { 52 variable fini 53 global tcl_platform drives 54 55 set unsetfini [namespace code {unset fini}] 56 # 57 # arguments 58 # 59 set _titre "Directory Selector" 60 set _ldir Directory: 61 set _ldnam "Directory Name:" 62 set _open Ok 63 set _expand Open 64 set _cancel Cancel 65 66 set ind 0 67 set max [llength $args] 68 while { $ind < $max } { 69 switch -exact -- [lindex $args $ind] { 70 "-initialdir" { 71 incr ind 72 cd [lindex $args $ind] 73 incr ind 74 } 75 "-title" { 76 incr ind 77 set _titre [lindex $args $ind] 78 incr ind 79 } 80 "-ok" { 81 incr ind 82 set _open [lindex $args $ind] 83 incr ind 84 } 85 "-open" { 86 incr ind 87 set _expand [lindex $args $ind] 88 incr ind 89 } 90 "-cancel" { 91 incr ind 92 set _cancel [lindex $args $ind] 93 incr ind 94 } 95 "-msg1" { 96 incr ind 97 set _ldir [lindex $args $ind] 98 incr ind 99 } 100 "-msg2" { 101 incr ind 102 set _ldnam [lindex $args $ind] 103 incr ind 104 } 105 default { 106 puts "unknown option [lindex $args $ind]" 107 return "" 108 } 109 } 110 } 111 112 # 113 # variables et data 114 # 115 set fini 0 116 117 image create bitmap b_up -data " 118 #define up_width 31 119 #define up_height 23 120 static unsigned char up_bits[] = { 121 0x00, 0x00, 0x00, 0x80, 0x00, 0x00, 0x00, 0x80, 0x00, 0x00, 0x00, 0x80, 122 0x00, 0x00, 0x00, 0x80, 0x00, 0x3f, 0x00, 0x80, 0x80, 0x40, 0x00, 0x80, 123 0x40, 0x80, 0x00, 0x80, 0xe0, 0xff, 0xff, 0x83, 0x20, 0x00, 0x00, 0x82, 124 0x20, 0x04, 0x00, 0x82, 0x20, 0x0e, 0x00, 0x82, 0x20, 0x1f, 0x00, 0x82, 125 0x20, 0x04, 0x00, 0x82, 0x20, 0x04, 0x00, 0x82, 0x20, 0x04, 0x00, 0x82, 126 0x20, 0xfc, 0x0f, 0x82, 0x20, 0x00, 0x00, 0x82, 0x20, 0x00, 0x00, 0x82, 127 0xe0, 0xff, 0xff, 0x83, 0x00, 0x00, 0x00, 0x80, 0x00, 0x00, 0x00, 0x80, 128 0x00, 0x00, 0x00, 0x80, 0x00, 0x00, 0x00, 0x80};" 129 130 image create bitmap b_dir -background #ffff80 -data " 131 #define dir_width 17 132 #define dir_height 16 133 static unsigned char dir_bits[] = { 134 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x01, 0x00, 0x10, 0x02, 0x00, 135 0x08, 0x04, 0x00, 0xfc, 0x7f, 0x00, 0x04, 0x40, 0x00, 0x04, 0x40, 0x00, 136 0x04, 0x40, 0x00, 0x04, 0x40, 0x00, 0x04, 0x40, 0x00, 0x04, 0x40, 0x00, 137 0x04, 0x40, 0x00, 0xfc, 0x7f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};" \ 138 -maskdata " 139 #define dirm_width 17 140 #define dirm_height 16 141 static unsigned char dirm_bits[] = { 142 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x01, 0x00, 0xf0, 0x03, 0x00, 143 0xf8, 0x07, 0x00, 0xfc, 0x7f, 0x00, 0xfc, 0x7f, 0x00, 0xfc, 0x7f, 0x00, 144 0xfc, 0x7f, 0x00, 0xfc, 0x7f, 0x00, 0xfc, 0x7f, 0x00, 0xfc, 0x7f, 0x00, 145 0xfc, 0x7f, 0x00, 0xfc, 0x7f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};" 146 147 switch -exact $tcl_platform(platform) { 148 unix { 149 font create myfont -family lucida -size 14 -weight bold 150 } 151 windows { 152 font create myfont -family courier -size 12 153 } 154 } 155 156 # 157 # widgets 158 # 159 set orig_pwd [pwd] 160 toplevel .dirsel 161 grab set .dirsel 162 163 wm geometry .dirsel 500x250 164 wm title .dirsel $_titre 165 166 frame .dirsel.f1 -relief flat -borderwidth 0 167 frame .dirsel.f2 -relief sunken -borderwidth 2 168 frame .dirsel.f3 -relief flat -borderwidth 0 169 frame .dirsel.f4 -relief flat -borderwidth 0 170 171 pack .dirsel.f1 -fill x 172 pack .dirsel.f2 -fill both -expand 1 -padx 6 -pady 6 173 pack .dirsel.f3 -fill x 174 pack .dirsel.f4 -fill x 175 176 label .dirsel.f1.lab -text $_ldir 177 menubutton .dirsel.f1.dir -relief raised -indicatoron 1 -anchor w \ 178 -menu .dirsel.f1.dir.m 179 menu .dirsel.f1.dir.m -tearoff 0 180 button .dirsel.f1.up -image b_up -command UpDir 181 182 pack .dirsel.f1.up -side right -padx 4 -pady 4 183 pack .dirsel.f1.lab -side left -padx 4 -pady 4 184 pack .dirsel.f1.dir -side right -padx 4 -pady 4 -fill x -expand 1 185 186 canvas .dirsel.f2.cv -borderwidth 0 -yscrollcommand ".dirsel.f2.sb set" 187 if ![string compare $tcl_platform(platform) windows] { 188 .dirsel.f2.cv configure -background white 189 } 190 scrollbar .dirsel.f2.sb -command ".dirsel.f2.cv yview" 191 set scw 16 192 place .dirsel.f2.cv -x 0 -relwidth 1.0 -width [expr -$scw ] -y 0 \ 193 -relheight 1.0 194 place .dirsel.f2.sb -relx 1.0 -x [expr -$scw ] -width $scw -y 0 \ 195 -relheight 1.0 196 unset scw 197 198 .dirsel.f2.cv bind TXT <Any-Enter> EnterItem 199 .dirsel.f2.cv bind TXT <Any-Leave> LeaveItem 200 .dirsel.f2.cv bind TXT <Any-Button> ClickItem 201 .dirsel.f2.cv bind TXT <Double-Button> DoubleClickItem 202 .dirsel.f2.cv bind IMG <Any-Enter> EnterItem 203 .dirsel.f2.cv bind IMG <Any-Leave> LeaveItem 204 .dirsel.f2.cv bind IMG <Any-Button> ClickItem 205 .dirsel.f2.cv bind IMG <Double-Button> DoubleClickItem 206 207 label .dirsel.f3.lnam -text $_ldnam 208 entry .dirsel.f3.chosen -takefocus 0 209 pack .dirsel.f3.lnam -side left -padx 4 -pady 4 210 pack .dirsel.f3.chosen -side right -fill x -expand 1 -padx 4 -pady 4 211 212 button .dirsel.f4.open -text $_open -command { 213 set tmp [.dirsel.f3.chosen get] 214 set fini 1 215 } 216 button .dirsel.f4.expand -text $_expand -command DownDir 217 button .dirsel.f4.cancel -text $_cancel -command { 218 set fini -1 219 } 220 221 pack .dirsel.f4.open .dirsel.f4.expand -side left -padx 10 -pady 4 222 pack .dirsel.f4.cancel -side right -padx 10 -pady 4 223 224#### Kish Shen: clean up if window killed 225 bind .dirsel.f4.open <Destroy> "cd \"$orig_pwd\"; font delete myfont; unset drives; eval $unsetfini" 226 227 # 228 # realwork 229 # 230 ShowDir [pwd] 231 232 # 233 # wait user 234 # 235 tkwait variable fini 236 237 if ![info exists fini] {return ""} ;# window was destroyed 238 if { $fini == 1 } { 239 set curdir [.dirsel.f1.dir cget -text] 240 set nnam [.dirsel.f3.chosen get] 241 if {[string length $nnam] == 0} { 242 set retval $curdir 243 } else { 244 set retval [ file join $curdir $nnam ] ;# make sure it is valid 245 if ![file exists $retval] {set retval $curdir} 246 } 247 cd $retval 248 } else { 249 set retval "" 250 } 251 252# font delete myfont 253 destroy .dirsel 254# unset drives fini 255# cleanup is done by bindings to Destroy 256 if ![file exists $retval] {set retval {}} ;# make sure returned path is valid 257 return $retval 258} 259 260proc ShowDir {curdir} { 261 262 global tcl_platform 263 variable drives 264 265 cd $curdir 266 .dirsel.f1.dir configure -text $curdir 267 268 set hi1 [font metrics myfont -linespace] 269 set hi2 [image height b_dir] 270 if { $hi1 > $hi2 } { 271 set hi $hi1 272 } else { 273 set hi $hi2 274 } 275 set wi1 [image width b_dir] 276 incr wi1 4 277 set wi2 [winfo width .dirsel.f2.cv] 278 279 set lidir [list] 280 foreach file [ glob -nocomplain * ] { 281 if [ file isdirectory [string trim $file "~"] ] { 282 lappend lidir $file 283 } 284 } 285 set sldir [lsort $lidir] 286 287 .dirsel.f2.cv delete all 288 set ind 0 289 foreach file $sldir { 290 if [ file isdirectory $file ] { 291 .dirsel.f2.cv create image 2 [expr $ind * $hi] \ 292 -anchor nw -image b_dir -tags IMG 293 .dirsel.f2.cv create text $wi1 [expr $ind * $hi] \ 294 -anchor nw -text $file -font myfont -tags TXT 295 set ind [ expr $ind + 1 ] 296 } 297 } 298 299 set ha [expr $ind * $hi] 300 .dirsel.f2.cv configure -scrollregion [list 0 0 $wi2 $ha] 301 302 set curlst [file split $curdir] 303 set nbr [llength $curlst] 304 305 .dirsel.f1.dir.m delete 0 last 306 incr nbr -2 307 for {set ind $nbr} {$ind >= 0} {incr ind -1} { 308 set tmplst [ lrange $curlst 0 $ind] 309 set tmpdir [ eval file join $tmplst] 310 .dirsel.f1.dir.m add command -label $tmpdir -command "ShowDir {$tmpdir}" 311 } 312 if {[info exist drives] == 0} { 313 set drives [file volume] 314 } 315 if ![string compare $tcl_platform(platform) windows] { 316 foreach drive $drives { 317 .dirsel.f1.dir.m add command -label $drive -command "ShowDir {$drive}" 318 } 319 } 320 321} 322 323proc UpDir {} { 324 set curdir [.dirsel.f1.dir cget -text] 325 set curlst [file split $curdir] 326 327 set nbr [llength $curlst] 328 if { $nbr < 2 } { 329 return 330 } 331 set tmp [expr $nbr - 2] 332 333 set newlst [ lrange $curlst 0 $tmp ] 334 set newdir [ eval file join $newlst ] 335 336 .dirsel.f3.chosen delete 0 end 337 ShowDir $newdir 338} 339 340proc DownDir {} { 341 set curdir [.dirsel.f1.dir cget -text] 342 set nnam [.dirsel.f3.chosen get] 343 344 set newdir [ file join $curdir $nnam ] 345 if ![file exists $newdir] {set newdir $curdir} 346 347 .dirsel.f3.chosen delete 0 end 348 ShowDir $newdir 349} 350 351proc EnterItem {} { 352 global tcl_platform 353 354 set id [.dirsel.f2.cv find withtag current] 355 set wt [.dirsel.f2.cv itemcget $id -tags] 356 if {[lsearch -exact $wt IMG] >= 0} { 357 set id [.dirsel.f2.cv find above $id] 358 } 359 if [string compare $tcl_platform(platform) windows] { 360 set cocol #00FF00 361 } else { 362 set cocol #0000FF 363 } 364 .dirsel.f2.cv itemconfigure $id -fill $cocol 365} 366 367proc LeaveItem {} { 368 set id [.dirsel.f2.cv find withtag current] 369 set wt [.dirsel.f2.cv itemcget $id -tags] 370 if {[lsearch -exact $wt IMG] >= 0} { 371 set id [.dirsel.f2.cv find above $id] 372 } 373 .dirsel.f2.cv itemconfigure $id -fill black 374} 375 376proc ClickItem {} { 377 .dirsel.f2.cv delete BOX 378 set id [.dirsel.f2.cv find withtag current] 379 set wt [.dirsel.f2.cv itemcget $id -tags] 380 if {[lsearch -exact $wt IMG] >= 0} { 381 set id [.dirsel.f2.cv find above $id] 382 } 383 set bxr [.dirsel.f2.cv bbox $id] 384 eval .dirsel.f2.cv create rectangle $bxr -fill #a2a2ff -outline #a2a2ff -tags BOX 385 .dirsel.f2.cv lower BOX 386 set nam [.dirsel.f2.cv itemcget $id -text] 387 .dirsel.f3.chosen delete 0 end 388 .dirsel.f3.chosen insert 0 $nam 389} 390 391proc DoubleClickItem {} { 392 set id [.dirsel.f2.cv find withtag current] 393 DownDir 394} 395 396