1
2#########################################################
3# Directory Selector TCL version 1.1
4#
5# Originally written by:
6# Daniel Roche, <dan@lectra.com>
7#
8# Modified for xmktclapp (and for version of Tk prior to 8.0) by:
9# D. Richard Hipp, <drh@hwaci.com>
10
11# tk_getDirectory [option value ...]
12#
13#  options are :
14#   [-parent window]      parent window
15#   [-initialdir dir]     display in dir
16#   [-title string]       make string title of dialog window
17#   [-ok string]          make string the label of OK button
18#   [-cancel string]      make string the label of CANCEL button
19#   [-label string]       make string the label of the directory message
20#   [-nofiles]            don't show files
21#
22
23proc tk_getDirectory {args} {
24  global tcl_platform tk_getDirectory
25
26  set _titre "Directory Selector"
27  set _ldir Directory:
28  set _open Ok
29  set _cancel Cancel
30  set _parent {}
31  set tk_getDirectory(curdir) [pwd]
32  set tk_getDirectory(showfiles) 1
33
34  set ind 0
35  set max [llength $args]
36  while { $ind < $max } {
37    switch -exact -- [lindex $args $ind] {
38      "-parent" {
39        incr ind
40        set _parent [lindex $args $ind]
41        incr ind
42      }
43      "-initialdir" {
44        incr ind
45        if {![catch {cd [lindex $args $ind]}]} {
46          set dir [pwd]
47          catch {cd $tk_getDirectory(curdir)}
48          set tk_getDirectory(curdir) $dir
49        }
50        incr ind
51      }
52      "-title" {
53        incr ind
54        set _titre [lindex $args $ind]
55        incr ind
56      }
57      "-ok" {
58        incr ind
59        set _open [lindex $args $ind]
60        incr ind
61      }
62      "-cancel" {
63        incr ind
64        set _cancel [lindex $args $ind]
65        incr ind
66      }
67      "-label" {
68        incr ind
69        set _ldir [lindex $args $ind]
70        incr ind
71      }
72      "-nofiles" {
73        set tk_getDirectory(showfiles) 0
74        incr ind
75      }
76      default {
77        puts "unknown option [lindex $args $ind]"
78        return ""
79      }
80    }
81  }
82
83  set tk_getDirectory(fini) 0
84
85  if {![info exists tk_getDirectory:b_up]} {
86    image create photo tk_getDirectory:b_up -data {\
87R0lGODlhEAAQALMAAAAAAIAAAACAAICAAAAAgIAAgACAgICAgMDAwP8AAAD/AP//AAAA//8A\
88/wD//////yH5BAEAAAgALAAAAAAQABAAQwQ4EMlJKwJvZaB7fsD1eSQolmV4kaqFaUA8fuG7\
89xTht7S7e9r4gTsKhzTo1mO+YNKKaqFFNSP3xKhEAOw==}
90
91    image create photo tk_getDirectory:b_new -data {\
92R0lGODlhEAAQALMAAAAAAIAAAACAAICAAAAAgIAAgACAgICAgMDAwP8AAAD/AP//AAAA//8A\
93/wD//////yH5BAEAAAgALAAAAAAQABAAQwQ1EMlJKwJv5a0BsNVHiZhmbiKohid5jVzsXl5t\
94p+uE569lS5+g7vZ7BU9IIRDJ2QGYph2vEgEAOw==}
95
96    image create photo tk_getDirectory:b_dir -data {\
97R0lGODlhEAAQALMAAAAAAIAAAACAAICAAAAAgIAAgACAgICAgMDAwP8AAAD/AP//AAAA//8A\
98/wD//////yH5BAEAAA4ALAAAAAAQABAAQwQ+0MlJqzsPLc33PsD1jGQ5gtehruwaXh1yWBIW\
99exxq47z80sAaK3i4yVq1R4+nUxo9zWUn+tSgHICsdrsNAiMAOw==}
100
101    image create photo tk_getDirectory:b_file -data {\
102R0lGODlhEAAQALMAAAAAAIAAAACAAICAAAAAgIAAgACAgICAgMDAwP8AAAD/AP//AAAA//8A\
103/wD//////yH5BAEAAAgALAAAAAAQABAAQwQ3EMlJ6wTvkb0zqJjWfR+Ycd1TXkDrrqZIZF6M\
104zir47rDlUyGaqicJ0l4x4TGpzAGbyyfU+atGAAA7}
105
106    image create bitmap tk_getDirectory:b_down -data "
107#define down_width 13
108#define down_height 10
109static unsigned char down_bits[] = {
110   0x00, 0x00, 0x00, 0x00, 0xfe, 0x0f, 0xfc, 0x07, 0xf8, 0x03, 0xf0, 0x01,
111   0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00};"
112  }
113
114  set w .dirsel
115  catch {destroy $w}
116
117  toplevel $w
118  wm geometry $w 420x220
119  wm title $w $_titre
120  if {$_parent == "" || ![winfo exists $_parent]} {
121    set _parent [winfo toplevel [winfo parent $w]]
122  } else {
123    set _parent [winfo toplevel $_parent]
124  }
125  wm transient $w $_parent
126
127  frame $w.f1 -relief flat -borderwidth 0
128  frame $w.f2 -relief sunken -borderwidth 1
129  frame $w.f3 -relief flat -borderwidth 0
130  pack $w.f1 -fill x -padx 6 -pady 5
131  pack $w.f2 -fill both -expand 1 -padx 6
132  pack $w.f3 -fill x -padx 6 -pady 3
133
134  label $w.f1.lab -text "Look In:"
135  frame $w.f1.dir -relief sunken -bd 2
136  entry $w.f1.dir.ent -relief flat -textvariable tk_getDirectory(curdir) \
137    -state disabled -cursor {}
138  menubutton $w.f1.dir.but -relief raised -image tk_getDirectory:b_down \
139    -menu $w.f1.dir.but.m -direction left
140  menu $w.f1.dir.but.m -tearoff 0
141  pack $w.f1.dir.ent -side left -fill x -expand 1
142  pack $w.f1.dir.but -side right -fill y
143  button $w.f1.up -image tk_getDirectory:b_up \
144    -command "tk_getDirectory:UpDir $w"
145  button $w.f1.new -image tk_getDirectory:b_new \
146    -command "tk_getDirectory:NewDir $w"
147  pack $w.f1.lab -side left
148  pack $w.f1.dir -side left -fill x -expand 1
149  pack $w.f1.new -side right
150  pack $w.f1.up -side right -padx 8
151
152  bind $w.f1.dir.but <1> "tk_getDirectory:Menu $w"
153  bind $w.f1.dir.ent <1> "tk_getDirectory:Menu $w;$w.f1.dir.but.m post %X %Y"
154
155  canvas $w.f2.cv -borderwidth 0 -xscrollcommand "$w.f2.sb set" \
156    -height 10 -bg white
157  scrollbar $w.f2.sb -command "$w.f2.cv xview" -orient horizontal
158  pack $w.f2.cv -side top -fill both -expand 1
159  pack $w.f2.sb -side top -fill x
160
161  $w.f2.cv bind TXT <Any-Button> "tk_getDirectory:HighlightItem $w"
162  $w.f2.cv bind IMG <Any-Button> "tk_getDirectory:HighlightItem $w"
163  $w.f2.cv bind TXT <Any-Double-Button> "tk_getDirectory:ClickItem $w"
164  $w.f2.cv bind IMG <Any-Double-Button> "tk_getDirectory:ClickItem $w"
165
166  label $w.f3.lab -text $_ldir
167  entry $w.f3.ent -relief sunken -textvariable tk_getDirectory(seldir) \
168    -state disabled -cursor {}
169  pack $w.f3.lab -side left
170  pack $w.f3.ent -side left -fill x -expand 1
171
172  set width [string length $_open]
173  if {$width < [string length $_cancel]} {
174    set width [string length $_cancel]
175  }
176  if {$tcl_platform(platform) == "windows"} {
177    button $w.f3.open -width $width -text $_open -pady 0 \
178      -default active -command {set tk_getDirectory(fini) 1}
179    button $w.f3.cancel -width $width -text $_cancel -pady 0 \
180      -command {set tk_getDirectory(fini) 0}
181  } else {
182    button $w.f3.open -width $width -text $_open \
183      -default active -command {set tk_getDirectory(fini) 1}
184    button $w.f3.cancel -width $width -text $_cancel \
185      -command {set tk_getDirectory(fini) 0}
186  }
187  pack $w.f3.cancel -side right
188  pack $w.f3.open -side right -padx 8
189
190  bind $w <Return> "$w.f3.open flash; set tk_getDirectory(fini) 1"
191
192  set oldFocus [focus]
193  set oldGrab [grab current $w]
194  if {$oldGrab != ""} {
195    set grabStatus [grab status $oldGrab]
196  }
197  catch {grab $w}
198
199  if {[winfo ismapped $_parent]} {
200    wm withdraw $w
201    wm geometry $w "+[winfo rootx $_parent]+[winfo rooty $_parent]"
202    update idletasks
203    wm deiconify $w
204  }
205  update
206  tk_getDirectory:ShowDir $w $tk_getDirectory(curdir)
207  focus -force $w
208  tkwait variable tk_getDirectory(fini)
209
210  if { $tk_getDirectory(fini) == 1 } {
211    set retval [eval file join [file split $tk_getDirectory(curdir)] \
212      $tk_getDirectory(seldir)]
213  } else {
214    set retval ""
215  }
216
217  catch {focus $oldFocus}
218  destroy $w
219  if {$oldGrab != ""} {
220    if {$grabStatus == "global"} {
221      grab -global $oldGrab
222    } else {
223      grab $oldGrab
224    }
225  }
226  return $retval
227}
228
229proc tk_getDirectory:ShowDir {w curdir} {
230  global tk_getDirectory
231
232  set tk_getDirectory(curdir) $curdir
233  $w.f1.dir.ent xview moveto 1.0
234
235  set wi [expr [image width tk_getDirectory:b_dir] + 3]
236  set hi [image height tk_getDirectory:b_dir]
237  set maxy [expr [winfo height $w.f2.cv]-$hi]
238
239  set lidir [list]
240  set lifile [list]
241  foreach file [glob -nocomplain $curdir/*] {
242    if [ file isdirectory $file ] {
243      lappend lidir [file tail $file]
244    } else {
245      lappend lifile [file tail $file]
246    }
247  }
248  set sldir [lsort $lidir]
249
250  $w.f2.cv delete all
251  set ind 0
252  set x 2
253  set y 2
254  foreach file $sldir {
255    $w.f2.cv create image $x $y -anchor nw \
256      -image tk_getDirectory:b_dir -tags IMG
257    $w.f2.cv create text [expr $x+$wi] $y -anchor nw -text $file -tags TXT
258    incr y $hi
259    if {$y >= $maxy} {
260      set bbox [$w.f2.cv bbox all]
261      set x [expr [lindex $bbox 2]+10]
262      set y 2
263    }
264  }
265  if {$tk_getDirectory(showfiles)} {
266    foreach file [lsort $lifile] {
267      $w.f2.cv create image $x $y -anchor nw -image tk_getDirectory:b_file
268      $w.f2.cv create text [expr $x+$wi] $y -anchor nw -text $file
269      incr y $hi
270      if {$y >= $maxy} {
271        set bbox [$w.f2.cv bbox all]
272        set x [expr [lindex $bbox 2]+10]
273        set y 2
274      }
275    }
276  }
277  $w.f2.cv configure -scrollregion [$w.f2.cv bbox all]
278  set tk_getDirectory(seldir) ""
279}
280
281proc tk_getDirectory:UpDir {w} {
282  global tk_getDirectory
283  set curdir $tk_getDirectory(curdir)
284  set curlst [file split $curdir]
285  set nbr [llength $curlst]
286  if {$nbr < 2} return
287  set tmp [expr $nbr - 2]
288  set newlst [ lrange $curlst 0 $tmp ]
289  set newdir [ eval file join $newlst ]
290  tk_getDirectory:ShowDir $w $newdir
291}
292
293proc tk_getDirectory:HighlightItem {w} {
294  global tk_getDirectory
295  catch {$w.f2.cv select clear}
296  set id [$w.f2.cv find withtag current]
297  if {[$w.f2.cv type $id] != "text"} {incr id}
298  $w.f2.cv select from $id 0
299  $w.f2.cv select to $id end
300  set tk_getDirectory(seldir) [$w.f2.cv itemcget $id -text]
301}
302
303proc tk_getDirectory:ClickItem {w} {
304  global tk_getDirectory
305  set id [$w.f2.cv find withtag current]
306  if {[$w.f2.cv type $id] != "text"} {incr id}
307  set dir [$w.f2.cv itemcget $id -text]
308  if {[string length $dir]==0} return
309  tk_getDirectory:ShowDir $w [file join $tk_getDirectory(curdir) $dir]
310}
311
312proc tk_getDirectory:Menu {w} {
313  global tk_getDirectory tcl_platform
314  if {![info exist tk_getDirectory(drives)]} {
315    if {$tcl_platform(platform) == "unix" ||
316      [catch {file volume} tk_getDirectory(drives)]} {
317      set tk_getDirectory(drives) {}
318    }
319    if {$tcl_platform(platform) == "windows"} {
320      set tk_getDirectory(drives) [string toupper $tk_getDirectory(drives)]
321    }
322  }
323  set curlst [file split $tk_getDirectory(curdir)]
324  set nbr [llength $curlst]
325  $w.f1.dir.but.m delete 0 last
326  incr nbr -2
327  set tmpdir {}
328  for {set ind $nbr} {$ind >= 0} {incr ind -1} {
329    set tmplst [ lrange $curlst 0 $ind]
330    set tmpdir [ eval file join $tmplst]
331    $w.f1.dir.but.m add command -label $tmpdir \
332      -command "tk_getDirectory:ShowDir $w [list $tmpdir]"
333  }
334  set rootdir [string toupper $tmpdir]
335  foreach drive $tk_getDirectory(drives) {
336    if {$drive != $rootdir} {
337      $w.f1.dir.but.m add command -label $drive \
338        -command "tk_getDirectory:ShowDir $w [list $drive]"
339    }
340  }
341}
342
343proc tk_getDirectory:NewDir {wref} {
344  global tcl_platform tk_getDirectory
345  set w .newdir
346  catch {destroy $w}
347  toplevel $w
348  wm title $w "New Folder"
349  wm transient $w $wref
350
351  set f [frame $w.name]
352  pack $f -side top -fill x -padx 5 -pady 5
353  label $f.lab -text "Name:"
354  pack $f.lab -side left
355  entry $f.ent -width 30
356  pack $f.ent -side left -fill x -expand 1
357  $f.ent insert 0 "New Folder"
358
359  set f [frame $w.but]
360  pack $f -side bottom -fill x -padx 5 -pady 5
361  button $f.accept -text Ok -width 6 -default active \
362    -command {set tk_getDirectory(newdir) 1}
363  bind $w <Return> "
364    $f.accept flash
365    set tk_getDirectory(newdir) 1
366  "
367  button $f.cancel -text Cancel -width 6 \
368    -command {set tk_getDirectory(newdir) 0}
369  pack $f.accept $f.cancel -side left -expand 1
370  if {$tcl_platform(platform) == "windows"} {
371    $f.accept configure -pady 0
372    $f.cancel configure -pady 0
373  }
374
375  wm withdraw $w
376  wm geometry $w \
377    "+[expr [winfo rootx $wref.f2.cv]+20]+[expr [winfo rooty $wref.f2.cv]+5]"
378  update idletasks
379  wm deiconify $w
380
381  set oldFocus [focus]
382  set oldGrab [grab current $w]
383  if {$oldGrab != ""} {
384    set grabStatus [grab status $oldGrab]
385  }
386  catch {grab $w}
387  tkwait visibility $w
388  $w.name.ent selection range 0 end
389  focus $w.name.ent
390  tkwait variable tk_getDirectory(newdir)
391
392  if {$tk_getDirectory(newdir)} {
393    set newdir "$tk_getDirectory(curdir)/[string trim [$w.name.ent get]]"
394  } else {
395    set newdir {}
396  }
397
398  catch {focus $oldFocus}
399  destroy $w
400  if {$oldGrab != ""} {
401    if {$grabStatus == "global"} {
402      grab -global $oldGrab
403    } else {
404      grab $oldGrab
405    }
406  }
407
408  if {$newdir != ""} {
409    if {[catch {file mkdir $newdir} msg]} {
410      tk_dialog .error Error $msg error 0 Ok
411    } else {
412      tk_getDirectory:ShowDir $wref $tk_getDirectory(curdir)
413    }
414  }
415}
416
417