0byt3m1n1
Path:
C:
/
Program Files
/
R
/
R-4.4.1
/
Tcl
/
lib
/
BWidget
/
[
Home
]
File: listbox.tcl
# ---------------------------------------------------------------------------- # listbox.tcl # This file is part of Unifix BWidget Toolkit # $Id: listbox.tcl,v 1.29.2.7 2012/04/12 12:46:47 oehhar Exp $ # ---------------------------------------------------------------------------- # Index of commands: # - ListBox::create # - ListBox::configure # - ListBox::cget # - ListBox::insert # - ListBox::itemconfigure # - ListBox::itemcget # - ListBox::bindText # - ListBox::bindImage # - ListBox::delete # - ListBox::move # - ListBox::reorder # - ListBox::selection # - ListBox::exists # - ListBox::index # - ListBox::item - deprecated # - ListBox::items # - ListBox::see # - ListBox::edit # - ListBox::xview # - ListBox::yview # - ListBox::_update_edit_size # - ListBox::_destroy # - ListBox::_see # - ListBox::_see_item # - ListBox::_update_scrollregion # - ListBox::_draw_item # - ListBox::_redraw_items # - ListBox::_redraw_selection # - ListBox::_redraw_listbox # - ListBox::_redraw_idle # - ListBox::_resize # - ListBox::_init_drag_cmd # - ListBox::_drop_cmd # - ListBox::_over_cmd # - ListBox::_auto_scroll # - ListBox::_scroll # ---------------------------------------------------------------------------- namespace eval ListBox { Widget::define ListBox listbox DragSite DropSite DynamicHelp namespace eval Item { Widget::declare ListBox::Item { {-indent Int 0 0 "%d >= 0"} {-text String "" 0} {-font String "" 0} {-foreground String "" 0} {-image TkResource "" 0 label} {-window String "" 0} {-data String "" 0} {-fill Synonym -foreground} {-fg Synonym -foreground} } } DynamicHelp::include ListBox::Item balloon Widget::tkinclude ListBox canvas .c \ remove { -insertwidth -insertbackground -insertborderwidth -insertofftime -insertontime -selectborderwidth -closeenough -confine -scrollregion -xscrollincrement -yscrollincrement -width -height } \ initialize { -relief sunken -borderwidth 2 -takefocus 1 -highlightthickness 1 -width 200 } DragSite::include ListBox "LISTBOX_ITEM" 1 DropSite::include ListBox { LISTBOX_ITEM {copy {} move {}} } Widget::declare ListBox { {-deltax Int 10 0 "%d >= 0"} {-deltay Int 15 0 "%d >= 0"} {-padx Int 20 0 "%d >= 0"} {-foreground TkResource "" 0 listbox} {-background TkResource "" 0 listbox} {-selectbackground TkResource "" 0 listbox} {-selectforeground TkResource "" 0 listbox} {-font TkResource "" 0 listbox} {-width TkResource "" 0 listbox} {-height TkResource "" 0 listbox} {-redraw Boolean 1 0} {-multicolumn Boolean 0 0} {-dropovermode Flag "wpi" 0 "wpi"} {-selectmode Enum none 0 {none single multiple}} {-fg Synonym -foreground} {-bg Synonym -background} {-dropcmd String "ListBox::_drag_and_drop" 0} {-autofocus Boolean 1 1} {-selectfill Boolean 0 1} } Widget::addmap ListBox "" .c {-deltay -yscrollincrement} bind ListBox <FocusIn> [list after idle {BWidget::refocus %W %W.c}] bind ListBox <Destroy> [list ListBox::_destroy %W] bind ListBox <Configure> [list ListBox::_resize %W] bind ListBoxFocus <1> [list focus %W] bind ListBox <Key-Up> [list ListBox::_keyboard_navigation %W -1] bind ListBox <Key-Down> [list ListBox::_keyboard_navigation %W 1] variable _edit } # ---------------------------------------------------------------------------- # Command ListBox::create # ---------------------------------------------------------------------------- proc ListBox::create { path args } { Widget::init ListBox $path $args variable $path upvar 0 $path data frame $path -class ListBox -bd 0 -highlightthickness 0 -relief flat \ -takefocus 0 # For 8.4+ we don't want to inherit the padding catch {$path configure -padx 0 -pady 0} # widget informations set data(nrows) -1 # items informations set data(items) {} set data(seeitem) {} set data(selitems) {} # update informations set data(upd,level) 0 set data(upd,afterid) "" set data(upd,level) 0 set data(upd,delete) {} # drag and drop informations set data(dnd,scroll) "" set data(dnd,afterid) "" set data(dnd,item) "" eval [list canvas $path.c] [Widget::subcget $path .c] \ [list -xscrollincrement 8] pack $path.c -expand yes -fill both DragSite::setdrag $path $path.c ListBox::_init_drag_cmd \ [Widget::cget $path -dragendcmd] 1 DropSite::setdrop $path $path.c ListBox::_over_cmd ListBox::_drop_cmd 1 Widget::create ListBox $path set w [Widget::cget $path -width] set h [Widget::cget $path -height] set dy [Widget::cget $path -deltay] $path.c configure -width [expr {$w*8}] -height [expr {$h*$dy}] # Insert $path into the canvas bindings, so that anyone binding # directly onto the widget will see their bindings activated when # the canvas has focus. set bindtags [bindtags $path.c] set bindtags [linsert $bindtags 1 $path] # Let any click within the canvas focus on the canvas so that # MouseWheel scroll events will be properly handled by the canvas. if {[Widget::cget $path -autofocus]} { lappend bindtags ListBoxFocus BWidget::bindMouseWheel $path.c } bindtags $path.c $bindtags # Add slightly modified up/down bindings to the canvas, in case # it gets the focus (like with -autofocus). bind $path.c <Key-Up> {ListBox::_keyboard_navigation [winfo parent %W] -1} bind $path.c <Key-Down> {ListBox::_keyboard_navigation [winfo parent %W] 1} _configureSelectmode $path [Widget::getoption $path -selectmode] return $path } # ---------------------------------------------------------------------------- # Command ListBox::_configureSelectmode # ---------------------------------------------------------------------------- # Configure the selectmode proc ListBox::_configureSelectmode { path selectmode {previous none} } { # clear current binding switch -exact -- $previous { single { $path _bindText <Button-1> "" $path _bindImage <Button-1> "" } multiple { $path _bindText <ButtonRelease-1> "" $path _bindText <Shift-ButtonRelease-1> "" $path _bindText <Control-ButtonRelease-1> "" $path _bindImage <ButtonRelease-1> "" $path _bindImage <Shift-ButtonRelease-1> "" $path _bindImage <Control-ButtonRelease-1> "" } } # set new bindings switch -exact -- $selectmode { single { $path _bindText <Button-1> [list ListBox::_mouse_select $path set] $path _bindImage <Button-1> [list ListBox::_mouse_select $path set] if {1 < [llength [ListBox::selection $path get]]} { ListBox::selection $path clear } } multiple { set cmd ListBox::_multiple_select $path _bindText <ButtonRelease-1> [list $cmd $path n %x %y] $path _bindText <Shift-ButtonRelease-1> [list $cmd $path s %x %y] $path _bindText <Control-ButtonRelease-1> [list $cmd $path c %x %y] $path _bindImage <ButtonRelease-1> [list $cmd $path n %x %y] $path _bindImage <Shift-ButtonRelease-1> [list $cmd $path s %x %y] $path _bindImage <Control-ButtonRelease-1> [list $cmd $path c %x %y] } default { if {0 < [llength [ListBox::selection $path get]]} { ListBox::selection $path clear } } } } # ---------------------------------------------------------------------------- # Command ListBox::configure # ---------------------------------------------------------------------------- proc ListBox::configure { path args } { set selectmodePrevious [Widget::getoption $path -selectmode] set res [Widget::configure $path $args] if { [Widget::hasChanged $path -selectmode selectmode] } { _configureSelectmode $path $selectmode $selectmodePrevious } set ch0 [expr {[Widget::hasChanged $path -deltay dy]}] set ch1 [expr {$ch0 | [Widget::hasChanged $path -padx val] | [Widget::hasChanged $path -multicolumn val]}] set ch2 [expr {[Widget::hasChanged $path -selectbackground val] | [Widget::hasChanged $path -selectforeground val]}] set redraw 0 if { [Widget::hasChanged $path -height h] || $ch0 } { $path.c configure -height [expr {$h*$dy}] if {!$ch0} { set redraw 1 } } if { [Widget::hasChanged $path -width w] } { $path.c configure -width [expr {$w*8}] set redraw 1 } if { [Widget::hasChanged $path -background bg] } { $path.c itemconfigure box -fill $bg } if { !$redraw } { if { $ch1 } { _redraw_idle $path 2 } elseif { $ch2 } { _redraw_idle $path 1 } } if { [Widget::hasChanged $path -redraw bool] && $bool } { variable $path upvar 0 $path data set lvl $data(upd,level) set data(upd,level) 0 _redraw_idle $path $lvl } set force [Widget::hasChanged $path -dragendcmd dragend] DragSite::setdrag $path $path.c ListBox::_init_drag_cmd $dragend $force DropSite::setdrop $path $path.c ListBox::_over_cmd ListBox::_drop_cmd return $res } # ---------------------------------------------------------------------------- # Command ListBox::cget # ---------------------------------------------------------------------------- proc ListBox::cget { path option } { return [Widget::cget $path $option] } # ---------------------------------------------------------------------------- # Command ListBox::insert # ---------------------------------------------------------------------------- proc ListBox::insert { path index item args } { variable $path upvar 0 $path data set item [Widget::nextIndex $path $item] if {[info exists data(exists,$item)]} { return -code error "item \"$item\" already exists" } Widget::init ListBox::Item $path.$item $args set data(items) [linsert $data(items) $index $item] set data(exists,$item) 1 set data(upd,create,$item) $item _redraw_idle $path 2 return $item } # Bastien Chevreux (bach@mwgdna.com) # The multipleinsert command performs inserts several items at once into # the list. It is faster than calling insert multiple times as it uses the # Widget::copyinit command for initializing all items after the 1st. The # speedup factor is between 2 and 3 for typical usage, but could be higher # for inserts with many options. # # Syntax: path and index are as in the insert command # args is a list of even numbered elements where the 1st of each pair # corresponds to the item of 'insert' and the second to args of 'insert'. # ---------------------------------------------------------------------------- # Command ListBox::multipleinsert # ---------------------------------------------------------------------------- proc ListBox::multipleinsert { path index args } { variable $path upvar 0 $path data # If we got only one list as arg, take the first element as args # This enables callers to use # $list multipleinsert index $thelist # instead of # eval $list multipleinsert index $thelist if {[llength $args] == 1} { set args [lindex $args 0] } set count 0 foreach {item iargs} $args { if {[info exists data(exists,$item)]} { return -code error "item \"$item\" already exists" } if {$count==0} { Widget::init ListBox::Item $path.$item $iargs set firstpath $path.$item } else { Widget::copyinit ListBox::Item $firstpath $path.$item $iargs } set data(items) [linsert $data(items) $index $item] set data(exists,$item) 1 set data(upd,create,$item) $item incr count } _redraw_idle $path 2 return $item } # ---------------------------------------------------------------------------- # Command ListBox::itemconfigure # ---------------------------------------------------------------------------- proc ListBox::itemconfigure { path item args } { variable $path upvar 0 $path data if { [lsearch -exact $data(items) $item] == -1 } { return -code error "item \"$item\" does not exist" } set oldind [Widget::getoption $path.$item -indent] set res [Widget::configure $path.$item $args] set chind [Widget::hasChanged $path.$item -indent indent] set chw [Widget::hasChanged $path.$item -window win] set chi [Widget::hasChanged $path.$item -image img] set cht [Widget::hasChanged $path.$item -text txt] set chf [Widget::hasChanged $path.$item -font fnt] set chfg [Widget::hasChanged $path.$item -foreground fg] set idn [$path.c find withtag n:$item] _set_help $path $item if { $idn == "" } { # item is not drawn yet _redraw_idle $path 2 return $res } set oldb [$path.c bbox $idn] set coords [$path.c coords $idn] set padx [Widget::getoption $path -padx] set x0 [expr {[lindex $coords 0]-$padx-$oldind+$indent}] set y0 [lindex $coords 1] if { $chw || $chi } { # -window or -image modified set idi [$path.c find withtag i:$item] set type [lindex [$path.c gettags $idi] 0] if { [string length $win] } { if { [string equal $type "win"] } { $path.c itemconfigure $idi -window $win } else { $path.c delete $idi $path.c create window $x0 $y0 -window $win -anchor w \ -tags [list win i:$item] } } elseif { [string length $img] } { if { [string equal $type "img"] } { $path.c itemconfigure $idi -image $img } else { $path.c delete $idi $path.c create image $x0 $y0 -image $img -anchor w \ -tags [list img imgbind i:$item] } } else { $path.c delete $idi } } if { $cht || $chf || $chfg } { # -text or -font modified, or -foreground modified set fnt [_getoption $path $item -font] set fg [_getoption $path $item -foreground] $path.c itemconfigure $idn -text $txt -font $fnt -fill $fg _redraw_idle $path 1 } if { $chind } { # -indent modified $path.c coords $idn [expr {$x0+$padx}] $y0 $path.c coords i:$item $x0 $y0 _redraw_idle $path 1 } if { [Widget::getoption $path -multicolumn] && ($cht || $chf || $chind) } { set bbox [$path.c bbox $idn] if { [lindex $bbox 2] > [lindex $oldb 2] } { _redraw_idle $path 2 } } return $res } # ---------------------------------------------------------------------------- # Command ListBox::itemcget # ---------------------------------------------------------------------------- proc ListBox::itemcget { path item option } { return [Widget::cget $path.$item $option] } # ---------------------------------------------------------------------------- # Command ListBox::_bindText # ---------------------------------------------------------------------------- proc ListBox::_bindText { path event script {tag click} } { if { $script != "" } { set map [list %W $path] set script [string map $map $script] append script " \[ListBox::_get_current [list $path]\]" } $path.c bind $tag $event $script } # ---------------------------------------------------------------------------- # Command ListBox::bindText # ---------------------------------------------------------------------------- proc ListBox::bindText { path event script } { _bindText $path $event $script clickbind } # ---------------------------------------------------------------------------- # Command ListBox::_bindImage # ---------------------------------------------------------------------------- proc ListBox::_bindImage { path event script {tag img} } { if { $script != "" } { set map [list %W $path] set script [string map $map $script] append script " \[ListBox::_get_current [list $path]\]" } $path.c bind $tag $event $script } # ---------------------------------------------------------------------------- # Command ListBox::bindImage # ---------------------------------------------------------------------------- proc ListBox::bindImage { path event script } { _bindImage $path $event $script imgbind } # ---------------------------------------------------------------------------- # Command ListBox::delete # ---------------------------------------------------------------------------- proc ListBox::delete { path args } { variable $path upvar 0 $path data Widget::getVariable $path help foreach litems $args { foreach item $litems { set idx [lsearch -exact $data(items) $item] if { $idx != -1 } { set data(items) [lreplace $data(items) $idx $idx] array unset help $item Widget::destroy $path.$item if { [info exists data(exists,$item)] } { unset data(exists,$item) } if { [info exists data(upd,create,$item)] } { unset data(upd,create,$item) } else { lappend data(upd,delete) $item } } } } set sel $data(selitems) set data(selitems) {} eval [list selection $path set] $sel _redraw_idle $path 2 } # ---------------------------------------------------------------------------- # Command ListBox::move # ---------------------------------------------------------------------------- proc ListBox::move { path item index } { variable $path upvar 0 $path data if { [set idx [lsearch -exact $data(items) $item]] == -1 } { return -code error "item \"$item\" does not exist" } set data(items) [linsert [lreplace $data(items) $idx $idx] $index $item] _redraw_idle $path 2 } # ---------------------------------------------------------------------------- # Command ListBox::reorder # ---------------------------------------------------------------------------- proc ListBox::reorder { path neworder } { variable $path upvar 0 $path data set data(items) [BWidget::lreorder $data(items) $neworder] _redraw_idle $path 2 } # ---------------------------------------------------------------------------- # Command ListBox::selection # ---------------------------------------------------------------------------- proc ListBox::selection { path cmd args } { variable $path upvar 0 $path data set oldsel $data(selitems); switch -- $cmd { set { set data(selitems) {} foreach item $args { if { [lsearch -exact $data(selitems) $item] == -1 } { if { [lsearch -exact $data(items) $item] != -1 } { lappend data(selitems) $item } } } } add { foreach item $args { if { [lsearch -exact $data(selitems) $item] == -1 } { if { [lsearch -exact $data(items) $item] != -1 } { lappend data(selitems) $item } } } } remove { foreach item $args { if { [set idx [lsearch -exact $data(selitems) $item]] != -1 } { set data(selitems) [lreplace $data(selitems) $idx $idx] } } } clear { set data(selitems) {} } get { return $data(selitems) } includes { return [expr {[lsearch -exact $data(selitems) $args] != -1}] } default { return } } if {[string compare $oldsel $data(selitems)]} { _redraw_idle $path 1 } return; } # ---------------------------------------------------------------------------- # Command ListBox::exists # ---------------------------------------------------------------------------- proc ListBox::exists { path item } { variable $path upvar 0 $path data return [expr {[lsearch -exact $data(items) $item] != -1}] } # ---------------------------------------------------------------------------- # Command ListBox::index # ---------------------------------------------------------------------------- proc ListBox::index { path item } { variable $path upvar 0 $path data if {[string equal $item "active"]} { return [$path selection get] } return [lsearch -exact $data(items) $item] } # ---------------------------------------------------------------------------- # ListBox::find # Returns the item given a position. # findInfo @x,y ?confine? # lineNumber # ---------------------------------------------------------------------------- proc ListBox::find {path findInfo {confine ""}} { variable $path upvar 0 $path widgetData if {[regexp -- {^@([0-9]+),([0-9]+)$} $findInfo match x y]} { set x [$path.c canvasx $x] set y [$path.c canvasy $y] } elseif {[regexp -- {^[0-9]+$} $findInfo lineNumber]} { set dy [Widget::getoption $path -deltay] set y [expr {$dy*($lineNumber+0.5)}] set confine "" } else { return -code error "invalid find spec \"$findInfo\"" } set found 0 set xi 0 foreach xs $widgetData(xlist) { if {$x <= $xs} { foreach id [$path.c find overlapping $xi $y $xs $y] { set ltags [$path.c gettags $id] set item [lindex $ltags 0] if { [string equal $item "item"] || [string equal $item "img"] || [string equal $item "win"] } { # item is the label or image/window of the node set item [ListBox::_get_node_name $path $id] set found 1 break } } break } set xi $xs } if {$found} { if {[string equal $confine "confine"]} { # test if x stand inside node bbox set xi [expr {[lindex [$path.c coords n:$item] 0]-[Widget::getoption $path -padx]}] set xs [lindex [$path.c bbox n:$item] 2] if {$x >= $xi && $x <= $xs} { return $item } } else { return $item } } return "" } # ---------------------------------------------------------------------------- # Command ListBox::item - deprecated # ---------------------------------------------------------------------------- proc ListBox::item { path first {last ""} } { variable $path upvar 0 $path data if { ![string length $last] } { return [lindex $data(items) $first] } else { return [lrange $data(items) $first $last] } } # ---------------------------------------------------------------------------- # Command ListBox::items # ---------------------------------------------------------------------------- proc ListBox::items { path {first ""} {last ""}} { variable $path upvar 0 $path data if { ![string length $first] } { return $data(items) } if { ![string length $last] } { return [lindex $data(items) $first] } else { return [lrange $data(items) $first $last] } } # ---------------------------------------------------------------------------- # Command ListBox::see # ---------------------------------------------------------------------------- proc ListBox::see { path item } { variable $path upvar 0 $path data if {$data(nrows) == -1} { # Not yet realized. set data(seeitem) $item return } if { [Widget::getoption $path -redraw] && $data(upd,afterid) != "" } { after cancel $data(upd,afterid) _redraw_listbox $path } _see_item $path $item; } # ---------------------------------------------------------------------------- # Command ListBox::edit # ---------------------------------------------------------------------------- proc ListBox::edit { path item text {verifycmd ""} {clickres 0} {select 1}} { variable _edit variable $path upvar 0 $path data if { [Widget::getoption $path -redraw] && $data(upd,afterid) != "" } { after cancel $data(upd,afterid) _redraw_listbox $path } set idn [$path.c find withtag n:$item] if { $idn != "" } { ListBox::_see $path $idn right ListBox::_see $path $idn left set oldfg [$path.c itemcget $idn -fill] set sbg [Widget::getoption $path -selectbackground] set coords [$path.c coords $idn] set x [lindex $coords 0] set y [lindex $coords 1] set bd [expr {[$path.c cget -borderwidth]+[$path.c cget -highlightthickness]}] set w [expr {[winfo width $path] - 2*$bd}] set wmax [expr {[$path.c canvasx $w]-$x}] $path.c itemconfigure $idn -fill [Widget::getoption $path -background] $path.c itemconfigure s:$item -fill {} -outline {} set _edit(text) $text set _edit(wait) 0 set frame [frame $path.edit \ -relief flat -borderwidth 0 -highlightthickness 0 \ -background [Widget::getoption $path -background]] set ent [entry $frame.edit \ -width 0 \ -relief solid \ -borderwidth 1 \ -highlightthickness 0 \ -foreground [_getoption $path $item -foreground] \ -background [Widget::getoption $path -background] \ -selectforeground [Widget::getoption $path -selectforeground] \ -selectbackground $sbg \ -font [_getoption $path $item -font] \ -textvariable ListBox::_edit(text)] pack $ent -ipadx 8 -anchor w set idw [$path.c create window $x $y -window $frame -anchor w] trace variable ListBox::_edit(text) w [list ListBox::_update_edit_size $path $ent $idw $wmax] tkwait visibility $ent grab $frame BWidget::focus set $ent _update_edit_size $path $ent $idw $wmax update if { $select } { $ent selection range 0 end $ent icursor end $ent xview end } bindtags $ent [list $ent Entry] bind $ent <Escape> {set ListBox::_edit(wait) 0} bind $ent <Return> {set ListBox::_edit(wait) 1} if { $clickres == 0 || $clickres == 1 } { bind $frame <Button> [list set ListBox::_edit(wait) $clickres] } set ok 0 while { !$ok } { tkwait variable ListBox::_edit(wait) if { !$_edit(wait) || [llength $verifycmd]==0 || [uplevel \#0 $verifycmd [list $_edit(text)]] } { set ok 1 } } trace vdelete ListBox::_edit(text) w [list ListBox::_update_edit_size $path $ent $idw $wmax] grab release $frame BWidget::focus release $ent destroy $frame $path.c delete $idw $path.c itemconfigure $idn -fill $oldfg $path.c itemconfigure s:$item -fill $sbg -outline $sbg if { $_edit(wait) } { return $_edit(text) } } return "" } # ---------------------------------------------------------------------------- # Command ListBox::xview # ---------------------------------------------------------------------------- proc ListBox::xview { path args } { return [eval [linsert $args 0 $path.c xview]] } # ---------------------------------------------------------------------------- # Command ListBox::yview # ---------------------------------------------------------------------------- proc ListBox::yview { path args } { return [eval [linsert $args 0 $path.c yview]] } proc ListBox::getcanvas { path } { return $path.c } proc ListBox::curselection { path } { return [$path selection get] } # ---------------------------------------------------------------------------- # Command ListBox::_update_edit_size # ---------------------------------------------------------------------------- proc ListBox::_update_edit_size { path entry idw wmax args } { set entw [winfo reqwidth $entry] if { $entw >= $wmax } { $path.c itemconfigure $idw -width $wmax } else { $path.c itemconfigure $idw -width 0 } } # ---------------------------------------------------------------------------- # Command ListBox::_getoption # Returns the value of option for node. If empty, returned value is those # of the ListBox. # ---------------------------------------------------------------------------- proc ListBox::_getoption { path item option } { set value [Widget::getoption $path.$item $option] if {![string length $value]} { set value [Widget::getoption $path $option] } return $value } # ---------------------------------------------------------------------------- # Command ListBox::_destroy # ---------------------------------------------------------------------------- proc ListBox::_destroy { path } { variable $path upvar 0 $path data if { $data(upd,afterid) != "" } { after cancel $data(upd,afterid) } if { $data(dnd,afterid) != "" } { after cancel $data(dnd,afterid) } foreach item $data(items) { Widget::destroy $path.$item } Widget::destroy $path unset data } # ---------------------------------------------------------------------------- # Command ListBox::_see # ---------------------------------------------------------------------------- proc ListBox::_see { path idn side } { set bbox [$path.c bbox $idn] set scrl [$path.c cget -scrollregion] set ymax [lindex $scrl 3] set dy [$path.c cget -yscrollincrement] set yv [$path.c yview] set yv0 [expr {round([lindex $yv 0]*$ymax/$dy)}] set yv1 [expr {round([lindex $yv 1]*$ymax/$dy)}] set y [expr {int([lindex [$path.c coords $idn] 1]/$dy)}] if { $y < $yv0 } { $path.c yview scroll [expr {$y-$yv0}] units } elseif { $y >= $yv1 } { $path.c yview scroll [expr {$y-$yv1+1}] units } set xmax [lindex $scrl 2] set dx [$path.c cget -xscrollincrement] set xv [$path.c xview] if { [string equal $side "right"] } { set xv1 [expr {round([lindex $xv 1]*$xmax/$dx)}] set x1 [expr {int([lindex $bbox 2]/$dx)}] if { $x1 >= $xv1 } { $path.c xview scroll [expr {$x1-$xv1+1}] units } } else { set xv0 [expr {round([lindex $xv 0]*$xmax/$dx)}] set x0 [expr {int([lindex $bbox 0]/$dx)}] if { $x0 < $xv0 } { $path.c xview scroll [expr {$x0-$xv0}] units } } } # ---------------------------------------------------------------------------- # Command ListBox::_see_item # ---------------------------------------------------------------------------- proc ListBox::_see_item { path item } { set idn [$path.c find withtag n:$item] if { $idn != "" } { set idi [$path.c find withtag i:$item] if { $idi == "" } { set idi $idn } _see $path $idn right _see $path $idi left } } # ---------------------------------------------------------------------------- # Command ListBox::_update_scrollregion # ---------------------------------------------------------------------------- proc ListBox::_update_scrollregion { path } { set bd [$path.c cget -borderwidth] set ht [$path.c cget -highlightthickness] set bd [expr {2*($bd + $ht)}] set w [expr {[winfo width $path] - $bd}] set h [expr {[winfo height $path] - $bd}] set xinc [$path.c cget -xscrollincrement] set yinc [$path.c cget -yscrollincrement] set bbox [$path.c bbox item win img] if { [llength $bbox] } { set xs [lindex $bbox 2] set ys [lindex $bbox 3] if { $w < $xs } { set w [expr {$xs + $w % $xinc}] } if { $h < $ys } { set h [expr {$ys + $h % $yinc}] } } $path.c configure -scrollregion [list 0 0 $w $h] } proc ListBox::_update_select_fill { path } { variable $path upvar 0 $path data set width [winfo width $path] foreach item $data(items) { set bbox [$path.c bbox n:$item] set bbox [list 0 [lindex $bbox 1] $width [lindex $bbox 3]] $path.c coords b:$item $bbox } _redraw_selection $path } # ---------------------------------------------------------------------------- # Command ListBox::_draw_item # ---------------------------------------------------------------------------- proc ListBox::_draw_item {path item x0 x1 y bg selfill multi ww} { set indent [Widget::getoption $path.$item -indent] set i [$path.c create text [expr {$x1+$indent}] $y \ -text [Widget::getoption $path.$item -text] \ -fill [_getoption $path $item -foreground] \ -font [_getoption $path $item -font] \ -anchor w \ -tags [list item n:$item click clickbind]] if { $selfill && !$multi } { set bbox [$path.c bbox n:$item] set bbox [list 0 [lindex $bbox 1] $ww [lindex $bbox 3]] set tags [list box b:$item click clickbind] $path.c create rect $bbox -fill $bg -width 0 -tags $tags $path.c raise $i } if { [set win [Widget::getoption $path.$item -window]] != "" } { $path.c create window [expr {$x0+$indent}] $y \ -window $win -anchor w -tags [list win i:$item] } elseif { [set img [Widget::getoption $path.$item -image]] != "" } { $path.c create image [expr {$x0+$indent}] $y \ -image $img -anchor w -tags [list img imgbind i:$item] } _set_help $path $item } # ---------------------------------------------------------------------------- # Command ListBox::_redraw_items # ---------------------------------------------------------------------------- proc ListBox::_redraw_items { path } { variable $path upvar 0 $path data set cursor [$path.c cget -cursor] $path.c configure -cursor watch update idletasks ; # make sure watch cursor is reflected set dx [Widget::getoption $path -deltax] set dy [Widget::getoption $path -deltay] set padx [Widget::getoption $path -padx] set y0 [expr {$dy/2}] # Changed from 4 to 2 to make highlight work and look nice for listbox with image as well set x0 2 set x1 [expr {$x0+$padx}] set nitem 0 set width 0 set drawn {} set data(xlist) {} if { [Widget::cget $path -multicolumn] } { set nrows $data(nrows) } else { set nrows [llength $data(items)] } foreach item $data(upd,delete) { $path.c delete i:$item n:$item s:$item b:$item } # Pass these to _draw_item so it doesn't have to request them # for each item. set bg [Widget::cget $path -background] set selfill [Widget::cget $path -selectfill] set multi [Widget::cget $path -multicolumn] set ww [winfo width $path] foreach item $data(items) { if { [info exists data(upd,create,$item)] } { _draw_item $path $item $x0 $x1 $y0 $bg $selfill $multi $ww unset data(upd,create,$item) } else { set indent [Widget::getoption $path.$item -indent] $path.c coords n:$item [expr {$x1+$indent}] $y0 $path.c coords i:$item [expr {$x0+$indent}] $y0 } set font [_getoption $path $item -font] set text [Widget::getoption $path.$item -text] set tw [font measure $font $text] if {$tw > $width} { set width $tw } incr y0 $dy incr nitem lappend drawn n:$item if { $nitem == $nrows } { set x2 [expr {$x1 + $width}] set y0 [expr {$dy/2}] set drawn {} set x0 [expr {$x2+$dx}] set x1 [expr {$x0+$padx}] set nitem 0 lappend data(xlist) $x2 set width 0 } } if { $nitem && $nitem < $nrows } { lappend data(xlist) [expr {$x1 + $width}] } set data(upd,delete) {} $path.c configure -cursor $cursor } # ---------------------------------------------------------------------------- # Command ListBox::_redraw_selection # ---------------------------------------------------------------------------- proc ListBox::_redraw_selection { path } { variable $path upvar 0 $path data set selbg [Widget::getoption $path -selectbackground] set selfg [Widget::getoption $path -selectforeground] set selfill [Widget::getoption $path -selectfill] set multi [Widget::getoption $path -multicolumn] foreach id [$path.c find withtag sel] { set item [ListBox::_get_node_name $path $id] if {-1 == [lsearch -exact $data(upd,delete) $item]} { $path.c itemconfigure "n:$item" \ -fill [_getoption $path $item -foreground] } } $path.c delete sel if {$selfill && !$multi} { # cache window width for use below set width [winfo width $path] } foreach item $data(selitems) { set bbox [$path.c bbox "n:$item"] if { [llength $bbox] } { set imgbox [$path.c bbox i:$item] lassign $bbox x0 y0 x1 y1; if {[string compare "" $imgbox]} { # image may exist and may be higher than text! lassign $imgbox ix0 iy0 ix1 iy1; set bbox [list $x0 [expr {$iy0<$y0?$iy0:$y0}] $x1 [expr {$iy1<$y1?$iy1:$y1}]]; } else { set bbox [list $x0 [lindex $bbox 1] $x1 [lindex $bbox 3]] } if { $selfill && !$multi } { # With -selectfill, make box occupy full width of widget set bbox [list 0 [lindex $bbox 1] $width [lindex $bbox 3]] } set tags [list sel s:$item click clickbind] set id [$path.c create rectangle $bbox \ -fill $selbg -outline $selbg -tags $tags] if {$selfg != ""} { # Don't allow an empty fill - that would be transparent $path.c itemconfigure "n:$item" -fill $selfg } $path.c lower $id $path.c lower b:$item } } } # ---------------------------------------------------------------------------- # Command ListBox::_redraw_listbox # ---------------------------------------------------------------------------- proc ListBox::_redraw_listbox { path } { variable $path upvar 0 $path data if { [Widget::getoption $path -redraw] } { if { $data(upd,level) == 2 } { _redraw_items $path } _redraw_selection $path _update_scrollregion $path if {[Widget::cget $path -selectfill]} { _update_select_fill $path } if {![string equal $data(seeitem) ""]} { _see_item $path $data(seeitem); } set data(upd,level) 0 set data(upd,afterid) "" set data(seeitem) ""; } } # ---------------------------------------------------------------------------- # Command ListBox::_redraw_idle # ---------------------------------------------------------------------------- proc ListBox::_redraw_idle { path level } { variable $path upvar 0 $path data if { $data(nrows) != -1 } { # widget is realized if { [Widget::getoption $path -redraw] && $data(upd,afterid) == "" } { set data(upd,afterid) \ [after idle [list ListBox::_redraw_listbox $path]] } } if { $level > $data(upd,level) } { set data(upd,level) $level } return "" } # ---------------------------------------------------------------------------- # Command ListBox::_resize # ---------------------------------------------------------------------------- proc ListBox::_resize { path } { variable $path upvar 0 $path data if { [Widget::getoption $path -multicolumn] } { set bd [expr {[$path.c cget -borderwidth]+[$path.c cget -highlightthickness]}] set h [expr {[winfo height $path] - 2*$bd}] set nrows [expr {$h/[$path.c cget -yscrollincrement]}] if { $nrows == 0 } { set nrows 1 } if { $nrows != $data(nrows) } { set data(nrows) $nrows _redraw_idle $path 2 } else { _update_scrollregion $path } } elseif { $data(nrows) == -1 } { # first Configure event set data(nrows) 0 ListBox::_redraw_listbox $path if {[Widget::cget $path -selectfill]} { _update_select_fill $path } } else { if {[Widget::cget $path -selectfill]} { _update_select_fill $path } _update_scrollregion $path } } # ---------------------------------------------------------------------------- # Command ListBox::_init_drag_cmd # ---------------------------------------------------------------------------- proc ListBox::_init_drag_cmd { path X Y top } { set path [winfo parent $path] set ltags [$path.c gettags current] set item [lindex $ltags 0] if { [string equal $item "item"] || [string equal $item "img"] || [string equal $item "win"] } { set item [ListBox::_get_node_name $path] if {[llength [set cmd [Widget::getoption $path -draginitcmd]]]} { return [uplevel \#0 $cmd [list $path $item $top]] } if { [set type [Widget::getoption $path -dragtype]] == "" } { set type "LISTBOX_ITEM" } if { [set img [Widget::getoption $path.$item -image]] != "" } { pack [label $top.l -image $img -padx 0 -pady 0] } return [list $type {copy move link} $item] } return {} } # ---------------------------------------------------------------------------- # Command ListBox::_drop_cmd # ---------------------------------------------------------------------------- proc ListBox::_drop_cmd { path source X Y op type dnddata } { set path [winfo parent $path] variable $path upvar 0 $path data if { [string length $data(dnd,afterid)] } { after cancel $data(dnd,afterid) set data(dnd,afterid) "" } $path.c delete drop set data(dnd,scroll) "" if { [llength $data(dnd,item)] || ![llength $data(items)] } { if {[llength [set cmd [Widget::getoption $path -dropcmd]]]} { return [uplevel \#0 $cmd [list $path $source $data(dnd,item) $op $type $dnddata]] } } return 0 } # ---------------------------------------------------------------------------- # Command ListBox::_over_cmd # ---------------------------------------------------------------------------- proc ListBox::_over_cmd { path source event X Y op type dnddata } { set path [winfo parent $path] variable $path upvar 0 $path data if { [string equal $event "leave"] } { # we leave the window listbox $path.c delete drop if { [string length $data(dnd,afterid)] } { after cancel $data(dnd,afterid) set data(dnd,afterid) "" } set data(dnd,scroll) "" return 0 } if { [string equal $event "enter"] } { # we enter the window listbox - dnd data initialization set mode [Widget::getoption $path -dropovermode] set data(dnd,mode) 0 foreach c {w p i} { set data(dnd,mode) [expr {($data(dnd,mode) << 1) | ([string first $c $mode] != -1)}] } } set x [expr {$X-[winfo rootx $path]}] set y [expr {$Y-[winfo rooty $path]}] $path.c delete drop set data(dnd,item) "" # test for auto-scroll unless mode is widget only if { $data(dnd,mode) != 4 && [_auto_scroll $path $x $y] != "" } { return 2 } if { $data(dnd,mode) & 4 } { # dropovermode includes widget set target [list widget] set vmode 4 } else { set target [list ""] set vmode 0 } if { ($data(dnd,mode) & 2) && ![llength $data(items)] } { # dropovermode includes position and listbox is empty lappend target "" 0 set vmode [expr {$vmode | 2}] } if { ($data(dnd,mode) & 3) && [llength $data(items)]} { # dropovermode includes item or position # we extract the box (xi,yi,xs,ys) where we can find item around x,y set len [llength $data(items)] set xc [$path.c canvasx $x] set yc [$path.c canvasy $y] set dy [$path.c cget -yscrollincrement] set line [expr {int($yc/$dy)}] set yi [expr {$line*$dy}] set ys [expr {$yi+$dy}] set xi 0 set pos $line if { [Widget::getoption $path -multicolumn] } { set nrows $data(nrows) } else { set nrows $len } if { $line < $nrows } { foreach xs $data(xlist) { if { $xc <= $xs } { break } set xi $xs incr pos $nrows } if { $pos < $len } { set item [lindex $data(items) $pos] set xi [expr {[lindex [$path.c coords n:$item] 0]-[Widget::getoption $path -padx]-1}] if { $data(dnd,mode) & 1 } { # dropovermode includes item lappend target $item set vmode [expr {$vmode | 1}] } else { lappend target "" } if { $data(dnd,mode) & 2 } { # dropovermode includes position if { $yc >= $yi+$dy/2 } { # position is after $item incr pos set yl $ys } else { # position is before $item set yl $yi } lappend target $pos set vmode [expr {$vmode | 2}] } else { lappend target "" } } else { lappend target "" "" } } else { lappend target "" "" } if { ($vmode & 3) == 3 } { # result have both item and position # we compute what is the preferred method if { $yc-$yi <= 3 || $ys-$yc <= 3 } { lappend target "position" } else { lappend target "item" } } } if {$vmode && [llength [set cmd [Widget::getoption $path -dropovercmd]]]} { # user-defined dropover command set res [uplevel \#0 $cmd [list $source $target $op $type $dnddata]] set code [lindex $res 0] set vmode 0 if {$code & 1} { # update vmode switch -exact -- [lindex $res 1] { item {set vmode 1} position {set vmode 2} widget {set vmode 4} } } } else { if { ($vmode & 3) == 3 } { # result have both item and position # we choose the preferred method if { [string equal [lindex $target 3] "position"] } { set vmode [expr {$vmode & ~1}] } else { set vmode [expr {$vmode & ~2}] } } if { $data(dnd,mode) == 4 || $data(dnd,mode) == 0 } { # dropovermode is widget or empty - recall is not necessary set code 1 } else { set code 3 } } # draw dnd visual following vmode if {[llength $data(items)]} { if { $vmode & 1 } { set data(dnd,item) [list "item" [lindex $target 1]] $path.c create rectangle $xi $yi $xs $ys -tags drop } elseif { $vmode & 2 } { set data(dnd,item) [concat "position" [lindex $target 2]] $path.c create line $xi $yl $xs $yl -tags drop } elseif { $vmode & 4 } { set data(dnd,item) [list "widget"] } else { set code [expr {$code & 2}] } } if { $code & 1 } { DropSite::setcursor based_arrow_down } else { DropSite::setcursor dot } return $code } # ---------------------------------------------------------------------------- # Command ListBox::_auto_scroll # ---------------------------------------------------------------------------- proc ListBox::_auto_scroll { path x y } { variable $path upvar 0 $path data set xmax [winfo width $path] set ymax [winfo height $path] set scroll {} if { $y <= 6 } { if { [lindex [$path.c yview] 0] > 0 } { set scroll [list yview -1] DropSite::setcursor sb_up_arrow } } elseif { $y >= $ymax-6 } { if { [lindex [$path.c yview] 1] < 1 } { set scroll [list yview 1] DropSite::setcursor sb_down_arrow } } elseif { $x <= 6 } { if { [lindex [$path.c xview] 0] > 0 } { set scroll [list xview -1] DropSite::setcursor sb_left_arrow } } elseif { $x >= $xmax-6 } { if { [lindex [$path.c xview] 1] < 1 } { set scroll [list xview 1] DropSite::setcursor sb_right_arrow } } if { [string length $data(dnd,afterid)] && ![string equal $data(dnd,scroll) $scroll] } { after cancel $data(dnd,afterid) set data(dnd,afterid) "" } set data(dnd,scroll) $scroll if { [llength $scroll] && ![string length $data(dnd,afterid)] } { set data(dnd,afterid) [after 200 [list ListBox::_scroll $path $scroll]] } return $data(dnd,afterid) } # ----------------------------------------------------------------------------- # Command ListBox::_multiple_select # ----------------------------------------------------------------------------- proc ListBox::_multiple_select { path mode x y idx } { variable $path upvar 0 $path data if { ![info exists data(anchor)] || ![info exists data(sel_anchor)] } { set data(anchor) $idx set data(sel_anchor) {} } switch -exact -- $mode { n { _mouse_select $path set $idx set data(anchor) $idx set data(sel_anchor) {} } c { set l [$path selection get] if { [lsearch -exact $l $idx] >= 0 } { _mouse_select $path remove $idx } else { _mouse_select $path add $idx } set data(anchor) $idx set data(sel_anchor) {} } s { eval [list $path _mouse_select remove] $data(sel_anchor) set ix [$path index $idx] set ia [$path index $data(anchor)] if { $ix > $ia } { set istart $ia set iend $ix } else { set istart $ix set iend $ia } for { set i $istart } { $i <= $iend } { incr i } { set l [$path selection get] set t [$path items $i] set li [lsearch -exact $l $t] if { $li < 0 } { _mouse_select $path add $t lappend data(sel_anchor) $t } } } } } # ---------------------------------------------------------------------------- # Command ListBox::_scroll # ---------------------------------------------------------------------------- proc ListBox::_scroll { path scroll} { variable $path upvar 0 $path data set cmd [lindex $scroll 0] set dir [lindex $scroll 1] if { ($dir == -1 && [lindex [$path.c $cmd] 0] > 0) || ($dir == 1 && [lindex [$path.c $cmd] 1] < 1) } { $path $cmd scroll $dir units set data(dnd,afterid) \ [after 50 [list ListBox::_scroll $path $scroll]] } else { set data(dnd,afterid) "" DropSite::setcursor dot } } # ListBox::_set_help -- # # Register dynamic help for an item in the listbox. # # Arguments: # path ListBox to query # item Item in the listbox # force Optional argument to force a reset of the help # # Results: # none proc ListBox::_set_help { path node } { Widget::getVariable $path help set item $path.$node set opts [list -helptype -helptext -helpvar] foreach {cty ctx cv} [eval [linsert $opts 0 Widget::hasChangedX $item]] break set text [Widget::getoption $item -helptext] ## If we've never set help for this item before, and text is not blank, ## we need to setup help. We also need to reset help if any of the ## options have changed. if { (![info exists help($node)] && $text != "") || $cty || $ctx || $cv } { set help($node) 1 set type [Widget::getoption $item -helptype] switch $type { balloon { DynamicHelp::register $path.c balloon n:$node $text DynamicHelp::register $path.c balloon i:$node $text DynamicHelp::register $path.c balloon b:$node $text } variable { set var [Widget::getoption $item -helpvar] DynamicHelp::register $path.c variable n:$node $var $text DynamicHelp::register $path.c variable i:$node $var $text DynamicHelp::register $path.c variable b:$node $var $text } } } } # ListBox::_mouse_select -- # # Handle selection commands that are done by the mouse. If the # selection command returns true, we generate a <<ListboxSelect>> # event for the listbox. # # Arguments: # Standard arguments passed to a selection command. # # Results: # none proc ListBox::_mouse_select { path cmd args } { eval [linsert $args 0 selection $path $cmd] switch -- $cmd { "add" - "clear" - "remove" - "set" { event generate $path <<ListboxSelect>> } } } # ListBox::_get_node_name -- # # Given a listbox item, get the name of the node represented by that # item. # # Arguments: # path listbox to query # item Optional item to examine; if omitted, # defaults to "current" # # Results: # node name of the listbox node. proc ListBox::_get_node_name {path {item current}} { set tags [$path.c gettags $item] if {[lindex $tags 0] == "img"} { set node [string range [lindex $tags 2] 2 end] } else { set node [string range [lindex $tags 1] 2 end] } return $node } proc ListBox::_get_current { path } { return [ListBox::_get_node_name $path] } # ListBox::_drag_and_drop -- # # A default command to handle drag-and-drop functions local to this # listbox. With this as the default -dropcmd, the user can simply # enable drag-and-drop and be able to move items within this list # with no further code. # # Arguments: # Standard arguments passed to a dropcmd. # # Results: # none proc ListBox::_drag_and_drop { path from endItem operation type startItem } { set items [$path items] ## This proc only handles drag-and-drop commands within itself. ## If the widget this came from is not our widget (minus the canvas), ## we don't want to do anything. They need to handle this themselves. if {[winfo parent $from] != $path} { return } set place [lindex $endItem 0] set i [lindex $endItem 1] switch -- $place { "position" { set idx $i } "item" { set idx [$path index $i] } "widget" { set idx [llength $items] } } # Check if startItem is part of the current selection and process the # whole selection if so set selItems [selection $path get] if {-1 != [lsearch -exact $selItems $startItem]} { set dragItems $selItems } else { set dragItems [list $startItem] } # get drag indexes (to sort them) foreach dragItem $dragItems { lappend dragIdx [$path index $dragItem] } foreach pos [lsort -integer -indices $dragIdx] { set dragItem [lindex $dragItems $pos] set dragIdx [$path index $dragItem] if {$idx > $dragIdx} { incr idx -1 } if {[string equal $operation "copy"]} { set options [Widget::options $path.$dragItem] eval [linsert $options 0 $path insert $idx $dragItem\#auto] incr idx } else { $path move $dragItem $idx set idx [$path index $dragItem] incr idx } } } proc ListBox::_keyboard_navigation { path dir } { variable $path upvar 0 $path data set sel [$path index [lindex [$path selection get] end]] if {$dir > 0} { incr sel if {$sel >= [llength $data(items)]} { return } } else { incr sel -1 if {$sel < 0} { return } } set item [lindex $data(items) $sel] $path see $item _mouse_select $path set $item }