proc selbox_newfn {sbref} \
{
upvar
set fn $sb(toplevel).f.fn.name
set name [$fn get]
debug $name
}
proc selbox_newbase {sbref} \
{
global $sbref
upvar
set fb_list $sb(toplevel).f.lists.basename
set bs [$fb_list curselection]
if {[llength $bs] == 1} \
{
set base [$fb_list get $bs]
debug base=$base
set path [split $sb(fn) /]
set len [llength $path]
set last [expr $len-1]
debug len=$len
if {$base == {..}} \
{
if {$len == 0} \
{
set $sbref\(fn) ..
} \
else \
{
if {[lindex $path $last] == {..}} \
{
append $sbref\(fn) /..
} \
else \
{
set $sbref\(fn) [join [lrange $path 0 $last] /]
}
}
} \
else \
{
if {$len == 0} \
{
set $sbref\(fn) $base
} \
else \
{
incr last -1
debug [list set $sbref\(fn) [join [concat [lrange $path 0 $last] $base] /]]
set $sbref\(fn) [join [concat [lrange $path 0 $last] $base] /]
}
}
debug "sb(fn)=$sb(fn)"
}
}
proc selbox_update {name elem op} \
{
debug ">selbox_update $name $elem $op"
upvar
set fb_list $sb(toplevel).f.lists.basename
$fb_list delete 0 end
$fb_list insert 0 ..
set dir [file dirname $sb(fn)]
set base [file tail $sb(fn)]
set names [lsort [glob $dir/{.*,*}]]
foreach name $names \
{
set name [file tail $name]
if {$name != {.} && $name != {..}} \
{
$fb_list insert end $name
if {$name == $base} \
{
$fb_list select from end
$fb_list yview end
}
}
}
}
proc selbox_tm_click {sbref} \
{
upvar
global pdus
set t $sb(toplevel).t.lists
set tm $t.modules
set tt $t.types
set ms [$tm curselection]
if {[llength $ms] == 1} \
{
$tt delete 0 end
eval $tt insert 0 $pdus([$tm get $ms])
}
}
proc selbox_ok {sbref} \
{
upvar
set fn $sb(toplevel).f.fn.name
set t $sb(toplevel).t.lists
set m $t.modules
set t $t.types
if {$sb(want_fn) && $sb(fn) == {} && $sb(force_fn)} \
{
tk_dialog .d {select filename} "You need to enter a file name" warning 0 Ok
return
}
if {$sb(want_ct)} \
{
set ms [$m curselection]
set ts [$t curselection]
if {[llength $ms] == 1 && [llength $ts] == 1} \
{
set sb(ct) "[$m get $ms] [$t get $ts]"
} \
else \
{
tk_dialog .d {select content type} "You need to select a content type" warning 0 Ok
return
}
}
set sb(rc) 1
destroy $sb(toplevel)
}
proc selbox_cancel {sbref} \
{
upvar
set sb(rc) 0
destroy $sb(toplevel)
}
set
proc selbox {filename_ref conttype_ref args} \
{
set prefix selbox
global while {[winfo exists [set toplevel .[set sbref $prefix${#sb}]]]} \
{
incr }
global $sbref
upvar
if {$filename_ref != {}} \
{
set sb(want_fn) 1
set sb(force_fn) 1
upvar $filename_ref filename
} \
else \
{
set sb(want_fn) 0
}
if {$conttype_ref != {}} \
{
set sb(want_ct) 1
upvar $conttype_ref conttype
} \
else \
{
set sb(want_ct) 0
}
foreach arg $args \
{
switch $arg \
{
nullfn \
{
set sb(force_fn) 0
}
default \
{
error "selbox: illegal argument $arg"
}
}
}
set sb(toplevel) [toplevel $toplevel]
wm minsize $toplevel 1 1
wm geometry $toplevel 300x300
set borderwidth 5
set relief ridge
if {$sb(want_fn)} \
{
set f [frame $toplevel.f -relief $relief -bd $borderwidth]
}
if {$sb(want_ct)} \
{
set t [frame $toplevel.t -relief $relief -bd $borderwidth]
}
set btns [frame $toplevel.btns -relief $relief -bd $borderwidth]
if {$sb(want_fn)} \
{
set flabel [label $f.label -text {File name:}]
set flists [frame $f.lists]
set fnf [frame $f.fn]
set fb_list [listbox $flists.basename -relief sunken -width 1 -height 1 -selectmode single]
set fb_sb [scrollbar $flists.base_sb]
$fb_list configure -yscrollcommand "$fb_sb set"
$fb_sb configure -command "$fb_list yview"
bind $fb_list <Double-Button-1> "selbox_newbase $sbref"
set fn [entry $fnf.name -relief sunken -textvariable $sbref\(fn)]
pack $fb_list -side left -expand 1 -fill both
pack $fb_sb -side left -fill y
pack $fn
pack $flabel -fill x
pack $fnf -fill x
pack $flists -expand 1 -fill both
trace variable $sbref\(fn) w selbox_update
if {[info exists filename]} \
{
set $sbref\(fn) $filename
} \
else \
{
set $sbref\(fn) {}
}
pack $f -expand 1 -fill both
}
if {$sb(want_ct)} \
{
set tlabel [label $t.label -text {Content type:}]
set tlists [frame $t.lists]
set tm [listbox $tlists.modules -exportselection 0 -relief sunken -width 1 -height 1 -selectmode single]
set tt [listbox $tlists.types -exportselection 0 -relief sunken -width 1 -height 1 -selectmode single]
set tm_sb [scrollbar $tlists.mod_sb]
set tt_sb [scrollbar $tlists.type_sb]
$tm configure -yscrollcommand "$tm_sb set"
$tm_sb configure -command "$tm yview"
global pdus
eval $tm insert 0 [array names pdus]
bind $tm <1> "[bind Listbox <1>]; selbox_tm_click $sbref"
pack $tm $tm_sb $tt $tt_sb -side left
pack configure $tm $tt -expand 1 -fill both
pack configure $tm_sb $tt_sb -fill y
pack $tlabel -fill x
pack $tlists -expand 1 -fill both
pack $t -expand 1 -fill both
}
button $btns.ok -text Ok -command "selbox_ok $sbref"
button $btns.cancel -text Cancel -command "selbox_cancel $sbref"
pack $btns.ok $btns.cancel -side left -padx 3m
pack $btns -fill x
set of [focus]
focus $fn
tkwait window $toplevel
if $sb(rc) \
{
if {$sb(want_fn)} { set filename $sb(fn) }
if {$sb(want_ct)} { set conttype $sb(ct) }
}
focus $of
return $sb(rc)
}