summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog6
-rw-r--r--library/iconlist.tcl97
-rw-r--r--library/megawidget.tcl142
-rw-r--r--library/tclIndex1
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]]