listbox.tcl

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

        # 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 && [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 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 [_mouse_select $path 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 cmd dir } {
    variable $path
    upvar 0  $path data

    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 100 ListBox::_scroll $path $cmd $dir]
    } 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 [list Widget::hasChangedX $item] $opts] 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 selection [list $path] [list $cmd] $args
    switch -- $cmd {
        "add" - "clear" - "remove" - "set" {
            event generate $path <<ListboxSelect>>
        }
    }
}


proc ListBox::_get_current { path } {
    set t [$path.c gettags current]
    return [string range [lindex $t 1] 2 end]
}


# 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]
        }
    }

    if {$idx > [$path index $startItem]} { incr idx -1 }

    if {[string equal $operation "copy"]} {
        set options [Widget::options $path.$startItem]
        eval $path insert $idx [list $startItem#auto] $options
    } else {
        $path move $startItem $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 }
    }
    _mouse_select $path set [lindex $data(items) $sel]
}