diff options
| -rw-r--r-- | ChangeLog | 6 | ||||
| -rw-r--r-- | library/iconlist.tcl | 97 | ||||
| -rw-r--r-- | library/megawidget.tcl | 142 | ||||
| -rw-r--r-- | library/tclIndex | 1 |
4 files changed, 179 insertions, 67 deletions
@@ -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]] |