Factor out the IconList megawidget.

1 files changed, 725 insertions, 0 deletions

diff --git a/library/iconlist.tcl b/library/iconlist.tcl
new file mode 100644
index 0000000..9828ecf
--- /dev/null
+++ b/library/iconlist.tcl
@@ -0,0 +1,725 @@
+# iconlist.tcl
+#
+#	Implements the icon-list megawidget used in the "Tk" standard file
+#	selection dialog boxes.
+#
+# RCS: @(#) $Id: iconlist.tcl,v 1.1 2009/02/12 21:32:49 dkf Exp $
+#
+# Copyright (c) 1994-1998 Sun Microsystems, Inc.
+# Copyright (c) 2009 Donal K. Fellows
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+
+package require Tk 8.6
+
+oo::class create ::tk::IconList {
+    variable w canvas list index itemList textList selection sbar \
+	maxIW maxIH maxTW maxTH numItems noScroll hull fill \
+	selected rect font itemsPerColumn options arrangeCB
+    constructor args {
+	set w [namespace tail [self]]
+	my configure {*}$args
+	rename [self] _$w
+	my Create
+	rename ::$w theFrame
+	rename [self] ::$w
+	set arrangeCB {}
+    }
+    self {
+	method unknown {w args} {
+	    if {[string match .* $w]} {
+		uplevel 1 [list [self] create $w {*}$args]
+		return $w
+	    }
+	    next $w {*}$args
+	}
+	unexport new unknown
+    }
+    destructor {
+	after cancel $arrangeCB
+	my Reset
+	if {[winfo exists $w]} {
+	    bind $hull <Destroy> {}
+	    destroy $w
+	}
+    }
+
+    # ----------------------------------------------------------------------
+
+    method index i {
+	if {![info exist list]} {
+	    set list {}
+	}
+	switch -regexp -- $i {
+	    "^-?[0-9]+$" {
+		if {$i < 0} {
+		    set i 0
+		}
+		if {$i >= [llength $list]} {
+		    set i [expr {[llength $list] - 1}]
+		}
+		return $i
+	    }
+	    "^anchor$" {
+		return $index(anchor)
+	    }
+	    "^end$" {
+		return [llength $list]
+	    }
+	    "@-?[0-9]+,-?[0-9]+" {
+		scan $i "@%d,%d" x y
+		set item [$canvas find closest \
+			[$canvas canvasx $x] [$canvas canvasy $y]]
+		return [lindex [$canvas itemcget $item -tags] 1]
+	    }
+	}
+    }
+
+    method selection {op args} {
+	switch -exact -- $op {
+	    anchor {
+		if {[llength $args] == 1} {
+		    set index(anchor) [$w index [lindex $args 0]]
+		} else {
+		    return $index(anchor)
+		}
+	    }
+	    clear {
+		switch [llength $args] {
+		    2 {
+			lassign $args first last
+		    }
+		    1 {
+			set first [set last [lindex $args 0]]
+		    }
+		    default {
+			return -code error "wrong # args: should be\
+			     \"[lrange [info level 0] 0 1] first ?last?\""
+		    }
+		}
+
+		set first [$w index $first]
+		set last [$w index $last]
+		if {$first > $last} {
+		    set tmp $first
+		    set first $last
+		    set last $tmp
+		}
+		set ind 0
+		foreach item $selection {
+		    if {$item >= $first} {
+			set first $ind
+			break
+		    }
+		    incr ind
+		}
+		set ind [expr {[llength $selection] - 1}]
+		for {} {$ind >= 0} {incr ind -1} {
+		    set item [lindex $selection $ind]
+		    if {$item <= $last} {
+			set last $ind
+			break
+		    }
+		}
+
+		if {$first > $last} {
+		    return
+		}
+		set selection [lreplace $selection $first $last]
+		event generate $w <<ListboxSelect>>
+		my DrawSelection
+	    }
+	    get {
+		return $selection
+	    }
+	    includes {
+		return [expr {[lindex $args 0] in $selection}]
+	    }
+	    set {
+		switch [llength $args] {
+		    2 {
+			lassign $args first last
+		    }
+		    1 {
+			set first [set last [lindex $args 0]]
+		    }
+		    default {
+			return -code error "wrong # args: should be\
+			     \"[lrange [info level 0] 0 1] first ?last?\""
+		    }
+		}
+
+		set first [$w index $first]
+		set last [$w index $last]
+		if {$first > $last} {
+		    set tmp $first
+		    set first $last
+		    set last $tmp
+		}
+
+		for {set i $first} {$i <= $last} {incr i} {
+		    lappend selection $i
+		}
+		set selection [lsort -integer -unique $selection]
+		event generate $w <<ListboxSelect>>
+		my DrawSelection
+	    }
+	}
+    }
+
+    method get item {
+	set rTag [lindex $list $item 2]
+	lassign $itemList($rTag) iTag tTag text serial
+	return $text
+    }
+
+    #	Configure the widget variables of IconList, according to the command
+    #	line arguments.
+    #
+    method configure args {
+	# 1: the configuration specs
+	#
+	set specs {
+	    {-command "" "" ""}
+	    {-font "" "" "TkIconFont"}
+	    {-multiple "" "" "0"}
+	}
+
+	# 2: parse the arguments
+	#
+	tclParseConfigSpec [my varname options] $specs "" $args
+    }
+
+    method cget option {
+	return $options($option)
+    }
+
+    #	Deletes all the items inside the canvas subwidget and reset the
+    #	iconList's state.
+    #
+    method deleteall {} {
+	$canvas delete all
+	unset -nocomplain selected rect list itemList
+	set maxIW 1
+	set maxIH 1
+	set maxTW 1
+	set maxTH 1
+	set numItems 0
+	set noScroll 1
+	set selection {}
+	set index(anchor) ""
+	$sbar set 0.0 1.0
+	$canvas xview moveto 0
+    }
+
+    #	Adds an icon into the IconList with the designated image and text
+    #
+    method add {image items} {
+	foreach text $items {
+	    set iID item$numItems
+	    set iTag [$canvas create image 0 0 -image $image -anchor nw \
+			  -tags [list icon $numItems $iID]]
+	    set tTag [$canvas create text  0 0 -text  $text  -anchor nw \
+			  -font $options(-font) -fill $fill \
+			  -tags [list text $numItems $iID]]
+	    set rTag [$canvas create rect  0 0 0 0 -fill "" -outline "" \
+			  -tags [list rect $numItems $iID]]
+
+	    lassign [$canvas bbox $iTag] x1 y1 x2 y2
+	    set iW [expr {$x2 - $x1}]
+	    set iH [expr {$y2 - $y1}]
+	    if {$maxIW < $iW} {
+		set maxIW $iW
+	    }
+	    if {$maxIH < $iH} {
+		set maxIH $iH
+	    }
+
+	    lassign [$canvas bbox $tTag] x1 y1 x2 y2
+	    set tW [expr {$x2 - $x1}]
+	    set tH [expr {$y2 - $y1}]
+	    if {$maxTW < $tW} {
+		set maxTW $tW
+	    }
+	    if {$maxTH < $tH} {
+		set maxTH $tH
+	    }
+
+	    lappend list [list $iTag $tTag $rTag $iW $iH $tW $tH $numItems]
+	    set itemList($rTag) [list $iTag $tTag $text $numItems]
+	    set textList($numItems) [string tolower $text]
+	    incr numItems
+	}
+	my ArrangeWhenIdle
+    }
+
+    #	Gets called when the user invokes the IconList (usually by
+    #	double-clicking or pressing the Return key).
+    #
+    method invoke {} {
+	if {$options(-command) ne "" && [llength $selection]} {
+	    uplevel #0 $options(-command)
+	}
+    }
+
+    #	If the item is not (completely) visible, scroll the canvas so that it
+    #	becomes visible.
+    #
+    method see rTag {
+	if {$noScroll} {
+	    return
+	}
+	set sRegion [$canvas cget -scrollregion]
+	if {$sRegion eq ""} {
+	    return
+	}
+
+	if {$rTag < 0 || $rTag >= [llength $list]} {
+	    return
+	}
+
+	set bbox [$canvas bbox item$rTag]
+	set pad [expr {[$canvas cget -highlightthickness]+[$canvas cget -bd]}]
+
+	set x1 [lindex $bbox 0]
+	set x2 [lindex $bbox 2]
+	incr x1 [expr {$pad * -2}]
+	incr x2 [expr {$pad * -1}]
+
+	set cW [expr {[winfo width $canvas] - $pad*2}]
+
+	set scrollW [expr {[lindex $sRegion 2]-[lindex $sRegion 0]+1}]
+	set dispX [expr {int([lindex [$canvas xview] 0]*$scrollW)}]
+	set oldDispX $dispX
+
+	# check if out of the right edge
+	#
+	if {($x2 - $dispX) >= $cW} {
+	    set dispX [expr {$x2 - $cW}]
+	}
+	# check if out of the left edge
+	#
+	if {($x1 - $dispX) < 0} {
+	    set dispX $x1
+	}
+
+	if {$oldDispX ne $dispX} {
+	    set fraction [expr {double($dispX) / double($scrollW)}]
+	    $canvas xview moveto $fraction
+	}
+    }
+
+    # ----------------------------------------------------------------------
+
+    method ArrangeWhenIdle {} {
+	if {$arrangeCB eq ""} {
+	    set arrangeCB [after idle [namespace code {my Arrange}]]
+	}
+	return
+    }
+
+    #	Places the icons in a column-major arrangement.
+    #
+    method Arrange {} {
+	set arrangeCB ""
+
+	if {![info exists list]} {
+	    if {[info exists canvas] && [winfo exists $canvas]} {
+		set noScroll 1
+		$sbar configure -command ""
+	    }
+	    return
+	}
+
+	set W [winfo width  $canvas]
+	set H [winfo height $canvas]
+	set pad [expr {[$canvas cget -highlightthickness]+[$canvas cget -bd]}]
+	if {$pad < 2} {
+	    set pad 2
+	}
+
+	incr W [expr {$pad*-2}]
+	incr H [expr {$pad*-2}]
+
+	set dx [expr {$maxIW + $maxTW + 8}]
+	if {$maxTH > $maxIH} {
+	    set dy $maxTH
+	} else {
+	    set dy $maxIH
+	}
+	incr dy 2
+	set shift [expr {$maxIW + 4}]
+
+	set x [expr {$pad * 2}]
+	set y [expr {$pad * 1}] ; # Why * 1 ?
+	set usedColumn 0
+	foreach sublist $list {
+	    set usedColumn 1
+	    lassign $sublist iTag tTag rTag iW iH tW tH
+
+	    set i_dy [expr {($dy - $iH)/2}]
+	    set t_dy [expr {($dy - $tH)/2}]
+
+	    $canvas coords $iTag $x                    [expr {$y + $i_dy}]
+	    $canvas coords $tTag [expr {$x + $shift}]  [expr {$y + $t_dy}]
+	    $canvas coords $rTag $x $y [expr {$x+$dx}] [expr {$y+$dy}]
+
+	    incr y $dy
+	    if {($y + $dy) > $H} {
+		set y [expr {$pad * 1}] ; # *1 ?
+		incr x $dx
+		set usedColumn 0
+	    }
+	}
+
+	if {$usedColumn} {
+	    set sW [expr {$x + $dx}]
+	} else {
+	    set sW $x
+	}
+
+	if {$sW < $W} {
+	    $canvas configure -scrollregion [list $pad $pad $sW $H]
+	    $sbar configure -command ""
+	    $canvas xview moveto 0
+	    set noScroll 1
+	} else {
+	    $canvas configure -scrollregion [list $pad $pad $sW $H]
+	    $sbar configure -command [list $canvas xview]
+	    set noScroll 0
+	}
+
+	set itemsPerColumn [expr {($H-$pad) / $dy}]
+	if {$itemsPerColumn < 1} {
+	    set itemsPerColumn 1
+	}
+
+	my DrawSelection
+    }
+
+    method DrawSelection {} {
+	$canvas delete selection
+	$canvas itemconfigure selectionText -fill black
+	$canvas dtag selectionText
+	set cbg [ttk::style lookup TEntry -selectbackground focus]
+	set cfg [ttk::style lookup TEntry -selectforeground focus]
+	foreach item $selection {
+	    set rTag [lindex $list $item 2]
+	    foreach {iTag tTag text serial} $itemList($rTag) {
+		break
+	    }
+
+	    set bbox [$canvas bbox $tTag]
+	    $canvas create rect $bbox -fill $cbg -outline $cbg \
+		-tags selection
+	    $canvas itemconfigure $tTag -fill $cfg -tags selectionText
+	}
+	$canvas lower selection
+	return
+    }
+
+    #	Creates an IconList widget by assembling a canvas widget and a
+    #	scrollbar widget. Sets all the bindings necessary for the IconList's
+    #	operations.
+    #
+    method Create {} {
+	ttk::frame $w
+	set hull [ttk::entry $w.cHull -takefocus 0]
+	set sbar [ttk::scrollbar $w.cHull.sbar -orient horizontal -takefocus 0]
+	catch {$sbar configure -highlightthickness 0}
+	set canvas [canvas $w.cHull.canvas -highlightthick 0 -takefocus 1 \
+			-width 400 -height 120 -background white]
+	pack $sbar -side bottom -fill x -padx 2 -in $hull -pady {0 2}
+	pack $canvas -expand yes -fill both -padx 2 -pady {2 0}
+	pack $hull -expand yes -fill both -ipadx 2 -ipady 2
+
+	$sbar configure -command [list $canvas xview]
+	$canvas configure -xscrollcommand [list $sbar set]
+
+	# Initializes the max icon/text width and height and other variables
+	#
+	set maxIW 1
+	set maxIH 1
+	set maxTW 1
+	set maxTH 1
+	set numItems 0
+	set noScroll 1
+	set selection {}
+	set index(anchor) ""
+	set fg [option get $canvas foreground Foreground]
+	if {$fg eq ""} {
+	    set fill black
+	} else {
+	    set fill $fg
+	}
+
+	# Creates the event bindings.
+	#
+	bind $canvas <Configure>	[namespace code {my ArrangeWhenIdle}]
+
+	bind $canvas <1>		[namespace code {my Btn1 %x %y}]
+	bind $canvas <B1-Motion>	[namespace code {my Motion1 %x %y}]
+	bind $canvas <B1-Leave>		[namespace code {my Leave1 %x %y}]
+	bind $canvas <Control-1>	[namespace code {my CtrlBtn1 %x %y}]
+	bind $canvas <Shift-1>		[namespace code {my ShiftBtn1 %x %y}]
+	bind $canvas <B1-Enter>		[list tk::CancelRepeat]
+	bind $canvas <ButtonRelease-1>	[list tk::CancelRepeat]
+	bind $canvas <Double-ButtonRelease-1> \
+	    [namespace code {my Double1 %x %y}]
+
+	bind $canvas <Control-B1-Motion> {;}
+	bind $canvas <Shift-B1-Motion>	[namespace code {my ShiftMotion1 %x %y}]
+
+	bind $canvas <Up>		[namespace code {my UpDown -1}]
+	bind $canvas <Down>		[namespace code {my UpDown  1}]
+	bind $canvas <Left>		[namespace code {my LeftRight -1}]
+	bind $canvas <Right>		[namespace code {my LeftRight  1}]
+	bind $canvas <Return>		[namespace code {my ReturnKey}]
+	bind $canvas <KeyPress>		[namespace code {my KeyPress %A}]
+	bind $canvas <Control-KeyPress> ";"
+	bind $canvas <Alt-KeyPress>	";"
+
+	bind $canvas <FocusIn>		[namespace code {my FocusIn}]
+	bind $canvas <FocusOut>		[namespace code {my FocusOut}]
+
+	bind $hull <Destroy>		[namespace code {my destroy}]
+
+	return $w
+    }
+
+    #	This procedure is invoked when the mouse leaves an entry window with
+    #	button 1 down.  It scrolls the window up, down, left, or right,
+    #	depending on where the mouse left the window, and reschedules itself
+    #	as an "after" command so that the window continues to scroll until the
+    #	mouse moves back into the window or the mouse button is released.
+    #
+    method AutoScan {} {
+	variable ::tk::Priv
+	if {![winfo exists $w]} return
+	set x $Priv(x)
+	set y $Priv(y)
+	if {$noScroll} {
+	    return
+	}
+	if {$x >= [winfo width $canvas]} {
+	    $canvas xview scroll 1 units
+	} elseif {$x < 0} {
+	    $canvas xview scroll -1 units
+	} elseif {$y >= [winfo height $canvas]} {
+	    # do nothing
+	} elseif {$y < 0} {
+	    # do nothing
+	} else {
+	    return
+	}
+	my Motion1 $x $y
+	set Priv(afterId) [after 50 [namespace code {my AutoScan}]]
+    }
+
+    # ----------------------------------------------------------------------
+
+    # Event handlers
+    method Btn1 {x y} {
+	focus $canvas
+	set i [$w index @$x,$y]
+	if {$i eq ""} {
+	    return
+	}
+	$w selection clear 0 end
+	$w selection set $i
+	$w selection anchor $i
+    }
+    method CtrlBtn1 {x y} {
+	if {$options(-multiple)} {
+	    focus $canvas
+	    set i [$w index @$x,$y]
+	    if {$i eq ""} {
+		return
+	    }
+	    if {[$w selection includes $i]} {
+		$w selection clear $i
+	    } else {
+		$w selection set $i
+		$w selection anchor $i
+	    }
+	}
+    }
+    method ShiftBtn1 {x y} {
+	if {$options(-multiple)} {
+	    focus $canvas
+	    set i [$w index @$x,$y]
+	    if {$i eq ""} {
+		return
+	    }
+	    if {[$w index anchor] eq ""} {
+		$w selection anchor $i
+	    }
+	    $w selection clear 0 end
+	    $w selection set anchor $i
+	}
+    }
+
+    #	Gets called on button-1 motions
+    #
+    method Motion1 {x y} {
+	variable ::tk::Priv
+	set Priv(x) $x
+	set Priv(y) $y
+	set i [$w index @$x,$y]
+	if {$i eq ""} {
+	    return
+	}
+	$w selection clear 0 end
+	$w selection set $i
+    }
+    method ShiftMotion1 {x y} {
+	variable ::tk::Priv
+	set Priv(x) $x
+	set Priv(y) $y
+	set i [$w index @$x,$y]
+	if {$i eq ""} {
+	    return
+	}
+	$w selection clear 0 end
+	$w selection set anchor $i
+    }
+    method Double1 {x y} {
+	if {[llength $selection]} {
+	    $w invoke
+	}
+    }
+    method ReturnKey {} {
+	$w invoke
+    }
+    method Leave1 {x y} {
+	variable ::tk::Priv
+	set Priv(x) $x
+	set Priv(y) $y
+	my AutoScan
+    }
+    method FocusIn {} {
+	$hull state focus
+	if {![info exists list]} {
+	    return
+	}
+	if {[llength $selection]} {
+	    my DrawSelection
+	}
+    }
+    method FocusOut {} {
+	$hull state !focus
+	$w selection clear 0 end
+    }
+
+    #	Moves the active element up or down by one element
+    #
+    # Arguments:
+    #	amount -	+1 to move down one item, -1 to move back one item.
+    #
+    method UpDown amount {
+	if {![info exists list]} {
+	    return
+	}
+	set curr [$w selection get]
+	if {[llength $curr] == 0} {
+	    set i 0
+	} else {
+	    set i [$w index anchor]
+	    if {$i eq ""} {
+		return
+	    }
+	    incr i $amount
+	}
+	$w selection clear 0 end
+	$w selection set $i
+	$w selection anchor $i
+	$w see $i
+    }
+
+    #	Moves the active element left or right by one column
+    #
+    # Arguments:
+    #	amount -	+1 to move right one column, -1 to move left one column
+    #
+    method LeftRight amount {
+	if {![info exists list]} {
+	    return
+	}
+	set curr [$w selection get]
+	if {[llength $curr] == 0} {
+	    set i 0
+	} else {
+	    set i [$w index anchor]
+	    if {$i eq ""} {
+		return
+	    }
+	    incr i [expr {$amount * $itemsPerColumn}]
+	}
+	$w selection clear 0 end
+	$w selection set $i
+	$w selection anchor $i
+	$w see $i
+    }
+
+    #	Gets called when user enters an arbitrary key in the listbox.
+    #
+    method KeyPress key {
+	variable ::tk::Priv
+	append Priv(ILAccel,[self]) $key
+	my Goto $Priv(ILAccel,[self])
+	catch {
+	    after cancel $Priv(ILAccel,[self],afterId)
+	}
+	set Priv(ILAccel,[self],afterId) \
+	    [after 500 [namespace code {my Reset}]]
+    }
+    method Goto text {
+	if {![info exists list]} {
+	    return
+	}
+	if {$text eq "" || $numItems == 0} {
+	    return
+	}
+
+	if {[llength [$w selection get]]} {
+	    set start [$w index anchor]
+	} else {
+	    set start 0
+	}
+	set theIndex -1
+	set less 0
+	set len [string length $text]
+	set len0 [expr {$len - 1}]
+	set i $start
+
+	# Search forward until we find a filename whose prefix is a
+	# case-insensitive match with $text
+	while {1} {
+	    if {[string equal -nocase -length $len0 $textList($i) $text]} {
+		set theIndex $i
+		break
+	    }
+	    incr i
+	    if {$i == $numItems} {
+		set i 0
+	    }
+	    if {$i == $start} {
+		break
+	    }
+	}
+
+	if {$theIndex > -1} {
+	    $w selection clear 0 end
+	    $w selection set $theIndex
+	    $w selection anchor $theIndex
+	    $w see $theIndex
+	}
+    }
+    method Reset {} {
+	variable ::tk::Priv
+
+	unset -nocomplain Priv(ILAccel,[self])
+    }
+}