listbox.tcl

The BWidget Toolkit is a high-level Widget Set for Tcl/Tk built using native Tcl/Tk 8.x namespaces.

# ----------------------------------------------------------------------------
#  listbox.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: listbox.tcl,v 1.17 2003/10/28 05:03:17 damonc 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
# ----------------------------------------------------------------------------

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 1 {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 <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
    # 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 -highlightthickness 1]
    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}]

    ## 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]} {
	bindtags $path.c [concat [bindtags $path.c] ListBoxFocus]
	BWidget::bindMouseWheel $path.c
    }

    switch -exact -- [Widget::getoption $path -selectmode] {
	single {
	    $path bindText  <Button-1> [list ListBox::_mouse_select $path set]
	    $path bindImage <Button-1> [list ListBox::_mouse_select $path set]
	}
	multiple {
	    set cmd ListBox::_multiple_select
	    $path bindText <Button-1>          [list $cmd $path n %x %y]
	    $path bindText <Shift-Button-1>    [list $cmd $path s %x %y]
	    $path bindText <Control-Button-1>  [list $cmd $path c %x %y]

	    $path bindImage <Button-1>         [list $cmd $path n %x %y]
	    $path bindImage <Shift-Button-1>   [list $cmd $path s %x %y]
	    $path bindImage <Control-Button-1> [list $cmd $path c %x %y]
	}
    }

    return $path
}


# ----------------------------------------------------------------------------
#  Command ListBox::configure
# ----------------------------------------------------------------------------
proc ListBox::configure { path args } {
    set res [Widget::configure $path $args]

    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 { [lsearch -exact $data(items) $item] != -1 } {
        return -code error "item \"$item\" already exists"
    }

    Widget::init ListBox::Item $path.$item $args

    set data(items) [linsert $data(items) $index $item]
    set data(upd,create,$item) $item

    _redraw_idle $path 2
    return $item
}

# Bastien Chevreux ([e-mail])
# 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 { [lsearch -exact $data(items) $item] != -1 } {
	    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(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
}


# ----------------------------------------------------------------------------