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