# ---------------------------------------------------------------------------- # listbox.tcl # This file is part of Unifix BWidget Toolkit # $Id: listbox.tcl,v 1.31 2010/05/12 08:22:19 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::_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 # - ListBox::_themechanged # ---------------------------------------------------------------------------- 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 Color "SystemWindowText" 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 Color "SystemWindowText" 0} {-background Color "SystemWindow" 0} {-selectbackground Color "SystemHighlight" 0} {-selectforeground Color "SystemHighlightText" 0} {-font String "TkTextFont" 0} {-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 [list after idle {BWidget::refocus %W %W.c}] bind ListBox [list ListBox::_destroy %W] bind ListBox [list ListBox::_resize %W] bind ListBoxFocus <1> [list focus %W] bind ListBox [list ListBox::_keyboard_navigation %W -1] bind ListBox [list ListBox::_keyboard_navigation %W 1] if {[lsearch [bindtags .] ListBoxThemeChanged] < 0} { bindtags . [linsert [bindtags .] 1 ListBoxThemeChanged] } 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(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 BWidget::bindMiddleMouseMovement $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 {ListBox::_keyboard_navigation [winfo parent %W] -1} bind $path.c {ListBox::_keyboard_navigation [winfo parent %W] 1} bind ListBoxThemeChanged <> \ "+ [namespace current]::_themechanged $path" _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 "" $path bindImage "" } multiple { $path bindText "" $path bindText "" $path bindText "" $path bindImage "" $path bindImage "" $path bindImage "" } } # set new bindings switch -exact -- $selectmode { single { $path bindText [list ListBox::_mouse_select $path set] $path bindImage [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 [list $cmd $path n %x %y] $path bindText [list $cmd $path s %x %y] $path bindText [list $cmd $path c %x %y] $path bindImage [list $cmd $path n %x %y] $path bindImage [list $cmd $path s %x %y] $path bindImage [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 ch1 [expr {[Widget::hasChanged $path -deltay dy] | [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] } { $path.c configure -height [expr {$h*$dy}] 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 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 } { if { $script != "" } { set map [list %W $path] set script [string map $map $script] append script " \[ListBox::_get_current [list $path]\]" } $path.c bind "click" $event $script } # ---------------------------------------------------------------------------- # Command ListBox::bindImage # ---------------------------------------------------------------------------- proc ListBox::bindImage { path event script } { if { $script != "" } { set map [list %W $path] set script [string map $map $script] append script " \[ListBox::_get_current [list $path]\]" } $path.c bind "img" $event $script } # ---------------------------------------------------------------------------- # 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 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 } } _redraw_idle $path 1 } # ---------------------------------------------------------------------------- # 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 [string range [lindex $ltags 1] 2 end] 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 { [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 } } # ---------------------------------------------------------------------------- # 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 {set ListBox::_edit(wait) 0} bind $ent {set ListBox::_edit(wait) 1} if { $clickres == 0 || $clickres == 1 } { bind $frame