figenc

[RADIOACTIVE] rsa and symmetric key encryption scripts and executables
git clone git://git.figbert.com/figenc.git
Log | Files | Refs | README

megawidget.tcl (9569B)


      1 # megawidget.tcl
      2 #
      3 #	Basic megawidget support classes. Experimental for any use other than
      4 #	the ::tk::IconList megawdget, which is itself only designed for use in
      5 #	the Unix file dialogs.
      6 #
      7 # Copyright (c) 2009-2010 Donal K. Fellows
      8 #
      9 # See the file "license.terms" for information on usage and redistribution of
     10 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
     11 #
     12 
     13 package require Tk 8.6
     14 
     15 ::oo::class create ::tk::Megawidget {
     16     superclass ::oo::class
     17     method unknown {w args} {
     18 	if {[string match .* $w]} {
     19 	    [self] create $w {*}$args
     20 	    return $w
     21 	}
     22 	next $w {*}$args
     23     }
     24     unexport new unknown
     25     self method create {name superclasses body} {
     26 	next $name [list \
     27 		superclass ::tk::MegawidgetClass {*}$superclasses]\;$body
     28     }
     29 }
     30 
     31 ::oo::class create ::tk::MegawidgetClass {
     32     variable w hull options IdleCallbacks
     33     constructor args {
     34 	# Extract the "widget name" from the object name
     35 	set w [namespace tail [self]]
     36 
     37 	# Configure things
     38 	tclParseConfigSpec [my varname options] [my GetSpecs] "" $args
     39 
     40 	# Move the object out of the way of the hull widget
     41 	rename [self] _tmp
     42 
     43 	# Make the hull widget(s)
     44 	my CreateHull
     45 	bind $hull <Destroy> [list [namespace which my] destroy]
     46 
     47 	# Rename things into their final places
     48 	rename ::$w theWidget
     49 	rename [self] ::$w
     50 
     51 	# Make the contents
     52 	my Create
     53     }
     54     destructor {
     55 	foreach {name cb} [array get IdleCallbacks] {
     56 	    after cancel $cb
     57 	    unset IdleCallbacks($name)
     58 	}
     59 	if {[winfo exists $w]} {
     60 	    bind $hull <Destroy> {}
     61 	    destroy $w
     62 	}
     63     }
     64 
     65     ####################################################################
     66     #
     67     # MegawidgetClass::configure --
     68     #
     69     #	Implementation of 'configure' for megawidgets. Emulates the operation
     70     #	of the standard Tk configure method fairly closely, which makes things
     71     #	substantially more complex than they otherwise would be.
     72     #
     73     #	This method assumes that the 'GetSpecs' method returns a description
     74     #	of all the specifications of the options (i.e., as Tk returns except
     75     #	with the actual values removed). It also assumes that the 'options'
     76     #	array in the class holds all options; it is up to subclasses to set
     77     #	traces on that array if they want to respond to configuration changes.
     78     #
     79     #	TODO: allow unambiguous abbreviations.
     80     #
     81     method configure args {
     82 	# Configure behaves differently depending on the number of arguments
     83 	set argc [llength $args]
     84 	if {$argc == 0} {
     85 	    return [lmap spec [my GetSpecs] {
     86 		lappend spec $options([lindex $spec 0])
     87 	    }]
     88 	} elseif {$argc == 1} {
     89 	    set opt [lindex $args 0]
     90 	    if {[info exists options($opt)]} {
     91 		set spec [lsearch -inline -index 0 -exact [my GetSpecs] $opt]
     92 		return [linsert $spec end $options($opt)]
     93 	    }
     94 	} elseif {$argc == 2} {
     95 	    # Special case for where we're setting a single option. This
     96 	    # avoids some of the costly operations. We still do the [array
     97 	    # get] as this gives a sufficiently-consistent trace.
     98 	    set opt [lindex $args 0]
     99 	    if {[dict exists [array get options] $opt]} {
    100 		# Actually set the new value of the option. Use a catch to
    101 		# allow a megawidget user to throw an error from a write trace
    102 		# on the options array to reject invalid values.
    103 		try {
    104 		    array set options $args
    105 		} on error {ret info} {
    106 		    # Rethrow the error to get a clean stack trace
    107 		    return -code error -errorcode [dict get $info -errorcode] $ret
    108 		}
    109 		return
    110 	    }
    111 	} elseif {$argc % 2 == 0} {
    112 	    # Check that all specified options exist. Any unknown option will
    113 	    # cause the merged dictionary to be bigger than the options array
    114 	    set merge [dict merge [array get options] $args]
    115 	    if {[dict size $merge] == [array size options]} {
    116 		# Actually set the new values of the options. Use a catch to
    117 		# allow a megawidget user to throw an error from a write trace
    118 		# on the options array to reject invalid values
    119 		try {
    120 		    array set options $args
    121 		} on error {ret info} {
    122 		    # Rethrow the error to get a clean stack trace
    123 		    return -code error -errorcode [dict get $info -errorcode] $ret
    124 		}
    125 		return
    126 	    }
    127 	    # Due to the order of the merge, the unknown options will be at
    128 	    # the end of the dict. This makes the first unknown option easy to
    129 	    # find.
    130 	    set opt [lindex [dict keys $merge] [array size options]]
    131 	} else {
    132 	    set opt [lindex $args end]
    133 	    return -code error -errorcode [list TK VALUE_MISSING] \
    134 		"value for \"$opt\" missing"
    135 	}
    136 	return -code error -errorcode [list TK LOOKUP OPTION $opt] \
    137 	    "bad option \"$opt\": must be [tclListValidFlags options]"
    138     }
    139 
    140     ####################################################################
    141     #
    142     # MegawidgetClass::cget --
    143     #
    144     #	Implementation of 'cget' for megawidgets. Emulates the operation of
    145     #	the standard Tk cget method fairly closely.
    146     #
    147     #	This method assumes that the 'options' array in the class holds all
    148     #	options; it is up to subclasses to set traces on that array if they
    149     #	want to respond to configuration reads.
    150     #
    151     #	TODO: allow unambiguous abbreviations.
    152     #
    153     method cget option {
    154 	return $options($option)
    155     }
    156 
    157     ####################################################################
    158     #
    159     # MegawidgetClass::TraceOption --
    160     #
    161     #	Sets up the tracing of an element of the options variable.
    162     #
    163     method TraceOption {option method args} {
    164 	set callback [list my $method {*}$args]
    165 	trace add variable options($option) write [namespace code $callback]
    166     }
    167 
    168     ####################################################################
    169     #
    170     # MegawidgetClass::GetSpecs --
    171     #
    172     #	Return a list of descriptions of options supported by this
    173     #	megawidget. Each option is described by the 4-tuple list, consisting
    174     #	of the name of the option, the "option database" name, the "option
    175     #	database" class-name, and the default value of the option. These are
    176     #	the same values returned by calling the configure method of a widget,
    177     #	except without the current values of the options.
    178     #
    179     method GetSpecs {} {
    180 	return {
    181 	    {-takefocus takeFocus TakeFocus {}}
    182 	}
    183     }
    184 
    185     ####################################################################
    186     #
    187     # MegawidgetClass::CreateHull --
    188     #
    189     #	Creates the real main widget of the megawidget. This is often a frame
    190     #	or toplevel widget, but isn't always (lightweight megawidgets might
    191     #	use a content widget directly).
    192     #
    193     #	The name of the hull widget is given by the 'w' instance variable. The
    194     #	name should be written into the 'hull' instance variable. The command
    195     #	created by this method will be renamed.
    196     #
    197     method CreateHull {} {
    198 	return -code error -errorcode {TCL OO ABSTRACT_METHOD} \
    199 	    "method must be overridden"
    200     }
    201 
    202     ####################################################################
    203     #
    204     # MegawidgetClass::Create --
    205     #
    206     #	Creates the content of the megawidget. The name of the widget to
    207     #	create the content in will be in the 'hull' instance variable.
    208     #
    209     method Create {} {
    210 	return -code error -errorcode {TCL OO ABSTRACT_METHOD} \
    211 	    "method must be overridden"
    212     }
    213 
    214     ####################################################################
    215     #
    216     # MegawidgetClass::WhenIdle --
    217     #
    218     #	Arrange for a method to be called on the current instance when Tk is
    219     #	idle. Only one such method call per method will be queued; subsequent
    220     #	queuing actions before the callback fires will be silently ignored.
    221     #	The additional args will be passed to the callback, and the callbacks
    222     #	will be properly cancelled if the widget is destroyed.
    223     #
    224     method WhenIdle {method args} {
    225 	if {![info exists IdleCallbacks($method)]} {
    226 	    set IdleCallbacks($method) [after idle [list \
    227 		    [namespace which my] DoWhenIdle $method $args]]
    228 	}
    229     }
    230     method DoWhenIdle {method arguments} {
    231 	unset IdleCallbacks($method)
    232 	tailcall my $method {*}$arguments
    233     }
    234 }
    235 
    236 ####################################################################
    237 #
    238 # tk::SimpleWidget --
    239 #
    240 #	Simple megawidget class that makes it easy create widgets that behave
    241 #	like a ttk widget. It creates the hull as a ttk::frame and maps the
    242 #	state manipulation methods of the overall megawidget to the equivalent
    243 #	operations on the ttk::frame.
    244 #
    245 ::tk::Megawidget create ::tk::SimpleWidget {} {
    246     variable w hull options
    247     method GetSpecs {} {
    248 	return {
    249 	    {-cursor cursor Cursor {}}
    250 	    {-takefocus takeFocus TakeFocus {}}
    251 	}
    252     }
    253     method CreateHull {} {
    254 	set hull [::ttk::frame $w -cursor $options(-cursor)]
    255 	my TraceOption -cursor UpdateCursorOption
    256     }
    257     method UpdateCursorOption args {
    258 	$hull configure -cursor $options(-cursor)
    259     }
    260     # Not fixed names, so can't forward
    261     method state args {
    262 	tailcall $hull state {*}$args
    263     }
    264     method instate args {
    265 	tailcall $hull instate {*}$args
    266     }
    267 }
    268 
    269 ####################################################################
    270 #
    271 # tk::FocusableWidget --
    272 #
    273 #	Simple megawidget class that makes a ttk-like widget that has a focus
    274 #	ring.
    275 #
    276 ::tk::Megawidget create ::tk::FocusableWidget ::tk::SimpleWidget {
    277     variable w hull options
    278     method GetSpecs {} {
    279 	return {
    280 	    {-cursor cursor Cursor {}}
    281 	    {-takefocus takeFocus TakeFocus ::ttk::takefocus}
    282 	}
    283     }
    284     method CreateHull {} {
    285 	ttk::frame $w
    286 	set hull [ttk::entry $w.cHull -takefocus 0 -cursor $options(-cursor)]
    287 	pack $hull -expand yes -fill both -ipadx 2 -ipady 2
    288 	my TraceOption -cursor UpdateCursorOption
    289     }
    290 }
    291 
    292 return
    293 
    294 # Local Variables:
    295 # mode: tcl
    296 # fill-column: 78
    297 # End: