Factor out some of the megawidget machinery.

4 files changed, 179 insertions, 67 deletions

diff --git a/ChangeLog b/ChangeLog
index 8c32167..a5880ae 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2010-03-12  Donal K. Fellows  <dkf@users.sf.net>
+
+	* library/iconlist.tcl:		Factor out some of the machinery for
+	* library/megawidget.tcl:	making a megawidget framework. Not a
+					public API at the moment.
+
 2010-03-11  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tkText.c (DumpLine): [Bug 2968379]: When peers are about,
diff --git a/library/iconlist.tcl b/library/iconlist.tcl
index 84f5612..2503181 100644
--- a/library/iconlist.tcl
+++ b/library/iconlist.tcl
@@ -3,7 +3,7 @@
 #	Implements the icon-list megawidget used in the "Tk" standard file
 #	selection dialog boxes.
 #
-# RCS: @(#) $Id: iconlist.tcl,v 1.3 2009/10/08 12:40:31 dkf Exp $
+# RCS: @(#) $Id: iconlist.tcl,v 1.4 2010/03/12 13:53:43 dkf Exp $
 #
 # Copyright (c) 1994-1998 Sun Microsystems, Inc.
 # Copyright (c) 2009 Donal K. Fellows
@@ -30,36 +30,24 @@
 
 package require Tk 8.6
 
-::oo::class create ::tk::IconList {
-    variable w hull canvas sbar accel accelCB arrangeCB fill font index \
+::tk::Megawidget create ::tk::IconList ::tk::FocusableWidget {
+    variable w canvas sbar accel accelCB fill font index \
 	itemList itemsPerColumn list maxIH maxIW maxTH maxTW noScroll \
 	numItems oldX oldY options rect selected selection textList
     constructor args {
-	set w [namespace tail [self]]
-	my configure {*}$args
-	rename [self] _$w
-	my Create
-	rename ::$w theFrame
-	rename [self] ::$w
-	set arrangeCB {}
+	next {*}$args
 	set accelCB {}
     }
-    self {
-	method unknown {w args} {
-	    if {[string match .* $w]} {
-		[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
+	next
+    }
+
+    method GetSpecs {} {
+	concat [next] {
+	    {-command "" "" ""}
+	    {-font "" "" "TkIconFont"}
+	    {-multiple "" "" "0"}
 	}
     }
 
@@ -192,27 +180,6 @@ package require Tk 8.6
 	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.
     #
@@ -269,7 +236,8 @@ package require Tk 8.6
 	    set textList($numItems) [string tolower $text]
 	    incr numItems
 	}
-	my ArrangeWhenIdle
+	my WhenIdle Arrange
+	return
     }
 
     #	Gets called when the user invokes the IconList (usually by
@@ -330,18 +298,9 @@ package require Tk 8.6
 
     # ----------------------------------------------------------------------
 
-    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
@@ -442,15 +401,13 @@ package require Tk 8.6
     #	operations.
     #
     method Create {} {
-	ttk::frame $w
-	set hull [ttk::entry $w.cHull -takefocus 0 -cursor {}]
-	set sbar [ttk::scrollbar $w.cHull.sbar -orient horizontal -takefocus 0]
+	variable hull
+	set sbar [ttk::scrollbar $hull.sbar -orient horizontal -takefocus 0]
 	catch {$sbar configure -highlightthickness 0}
-	set canvas [canvas $w.cHull.canvas -highlightthick 0 -takefocus 1 \
+	set canvas [canvas $hull.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 $sbar -side bottom -fill x -padx 2 -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]
@@ -474,7 +431,7 @@ package require Tk 8.6
 
 	# Creates the event bindings.
 	#
-	bind $canvas <Configure>	[namespace code {my ArrangeWhenIdle}]
+	bind $canvas <Configure>	[namespace code {my WhenIdle Arrange}]
 
 	bind $canvas <1>		[namespace code {my Btn1 %x %y}]
 	bind $canvas <B1-Motion>	[namespace code {my Motion1 %x %y}]
@@ -501,8 +458,6 @@ package require Tk 8.6
 	bind $canvas <FocusIn>		[namespace code {my FocusIn}]
 	bind $canvas <FocusOut>		[namespace code {my FocusOut}]
 
-	bind $hull <Destroy>		[namespace code {my destroy}]
-
 	return $w
     }
 
@@ -613,7 +568,7 @@ package require Tk 8.6
 	my AutoScan
     }
     method FocusIn {} {
-	$hull state focus
+	$w state focus
 	if {![info exists list]} {
 	    return
 	}
@@ -622,7 +577,7 @@ package require Tk 8.6
 	}
     }
     method FocusOut {} {
-	$hull state !focus
+	$w state !focus
 	$w selection clear 0 end
     }
 
@@ -654,7 +609,8 @@ package require Tk 8.6
     #	Moves the active element left or right by one column
     #
     # Arguments:
-    #	amount -	+1 to move right one column, -1 to move left one column
+    #	amount -	+1 to move right one column, -1 to move left one
+    #			column
     #
     method LeftRight amount {
 	if {![info exists list]} {
@@ -731,3 +687,10 @@ package require Tk 8.6
 	unset -nocomplain accel
     }
 }
+
+return
+
+# Local Variables:
+# mode: tcl
+# fill-column: 78
+# End:
diff --git a/library/megawidget.tcl b/library/megawidget.tcl
new file mode 100644
index 0000000..40033ea
--- /dev/null
+++ b/library/megawidget.tcl
@@ -0,0 +1,142 @@
+# megawidget.tcl
+#
+#	Basic megawidget support classes. Experimental for any use other than
+#	the ::tk::IconList megawdget, which is itself only designed for use in
+#	the Unix file dialogs.
+#
+# CVS: @(#) $Id: megawidget.tcl,v 1.1 2010/03/12 13:53:43 dkf Exp $
+#
+# Copyright (c) 2009-2010 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::Megawidget {
+    superclass ::oo::class
+    method unknown {w args} {
+	if {[string match .* $w]} {
+	    [self] create $w {*}$args
+	    return $w
+	}
+	next $w {*}$args
+    }
+    unexport new unknown
+    self method create {name superclasses body} {
+	next $name [list \
+		superclass ::tk::MegawidgetClass {*}$superclasses]\;$body
+    }
+}
+
+::oo::class create ::tk::MegawidgetClass {
+    variable w hull OptionSpecification options IdleCallbacks
+    constructor args {
+	# Extract the "widget name" from the object name
+	set w [namespace tail [self]]
+
+	# Configure things
+	set OptionSpecification [my GetSpecs]
+	my configure {*}$args
+
+	# Move the object out of the way of the hull widget
+	rename [self] _tmp
+
+	# Make the hull widget(s)
+	my CreateHull
+	bind $hull <Destroy> [list [namespace which my] destroy]
+
+	# Rename things into their final places
+	rename ::$w theFrame
+	rename [self] ::$w
+
+	# Make the contents
+	my Create
+    }
+    destructor {
+	foreach {name cb} [array get IdleCallbacks] {
+	    after cancel $cb
+	    unset IdleCallbacks($name)
+	}
+	if {[winfo exists $w]} {
+	    bind $hull <Destroy> {}
+	    destroy $w
+	}
+    }
+
+    method configure args {
+	tclParseConfigSpec [my varname options] $OptionSpecification "" $args
+    }
+    method cget option {
+	return $options($option)
+    }
+
+    method GetSpecs {} {
+	return {
+	    {-takefocus takeFocus TakeFocus {}}
+	}
+    }
+
+    method CreateHull {} {error "method must be overridden"}
+    method Create {}	 {error "method must be overridden"}
+
+    method WhenIdle {method args} {
+	if {![info exists IdleCallbacks($method)]} {
+	    set IdleCallbacks($method) [after idle [list \
+		    [namespace which my] DoWhenIdle $method $args]]
+	}
+    }
+    method DoWhenIdle {method arguments} {
+	unset IdleCallbacks($method)
+	tailcall my $method {*}$arguments
+    }
+}
+
+::tk::Megawidget create ::tk::SimpleWidget {} {
+    variable w hull options
+    method GetSpecs {} {
+	return {
+	    {-cursor cursor Cursor {}}
+	    {-takefocus takeFocus TakeFocus {}}
+	}
+    }
+    method CreateHull {} {
+	set hull [::ttk::frame $w -cursor $options(-cursor)]
+	trace add variable options(-cursor) write \
+	    [namespace code {my UpdateCursorOption}]
+    }
+    method UpdateCursorOption args {
+	$hull configure -cursor $options(-cursor)
+    }
+    method state args {
+	tailcall $hull state {*}$args
+    }
+    method instate args {
+	tailcall $hull instate {*}$args
+    }
+}
+
+::tk::Megawidget create ::tk::FocusableWidget ::tk::SimpleWidget {
+    variable w hull options
+    method GetSpecs {} {
+	return {
+	    {-cursor cursor Cursor {}}
+	    {-takefocus takeFocus TakeFocus ::ttk::takefocus}
+	}
+    }
+    method CreateHull {} {
+	ttk::frame $w
+	set hull [ttk::entry $w.cHull -takefocus 0 -cursor $options(-cursor)]
+	pack $hull -expand yes -fill both -ipadx 2 -ipady 2
+	trace add variable options(-cursor) write \
+	    [namespace code {my UpdateCursorOption}]
+    }
+}
+
+return
+
+# Local Variables:
+# mode: tcl
+# fill-column: 78
+# End:
diff --git a/library/tclIndex b/library/tclIndex
index 6729ff3..b3f37fa 100644
--- a/library/tclIndex
+++ b/library/tclIndex
@@ -90,6 +90,7 @@ set auto_index(::tk::ListboxExtendUpDown) [list source [file join $dir listbox.t
 set auto_index(::tk::ListboxDataExtend) [list source [file join $dir listbox.tcl]]
 set auto_index(::tk::ListboxCancel) [list source [file join $dir listbox.tcl]]
 set auto_index(::tk::ListboxSelectAll) [list source [file join $dir listbox.tcl]]
+set auto_index(::tk::Megawidget) [list source [file join $dir megawidget.tcl]]
 set auto_index(::tk::MbEnter) [list source [file join $dir menu.tcl]]
 set auto_index(::tk::MbLeave) [list source [file join $dir menu.tcl]]
 set auto_index(::tk::MbPost) [list source [file join $dir menu.tcl]]