This repository has been archived on 2024-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
BiblioMxWeb/windowsAgent/dist/tk/megawidget.tcl
2021-06-17 01:30:13 +02:00

298 lines
9.3 KiB
Tcl
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

# 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.
#
# 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 options IdleCallbacks
constructor args {
# Extract the "widget name" from the object name
set w [namespace tail [self]]
# Configure things
tclParseConfigSpec [my varname options] [my GetSpecs] "" $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 theWidget
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
}
}
####################################################################
#
# MegawidgetClass::configure --
#
# Implementation of 'configure' for megawidgets. Emulates the operation
# of the standard Tk configure method fairly closely, which makes things
# substantially more complex than they otherwise would be.
#
# This method assumes that the 'GetSpecs' method returns a description
# of all the specifications of the options (i.e., as Tk returns except
# with the actual values removed). It also assumes that the 'options'
# array in the class holds all options; it is up to subclasses to set
# traces on that array if they want to respond to configuration changes.
#
# TODO: allow unambiguous abbreviations.
#
method configure args {
# Configure behaves differently depending on the number of arguments
set argc [llength $args]
if {$argc == 0} {
return [lmap spec [my GetSpecs] {
lappend spec $options([lindex $spec 0])
}]
} elseif {$argc == 1} {
set opt [lindex $args 0]
if {[info exists options($opt)]} {
set spec [lsearch -inline -index 0 -exact [my GetSpecs] $opt]
return [linsert $spec end $options($opt)]
}
} elseif {$argc == 2} {
# Special case for where we're setting a single option. This
# avoids some of the costly operations. We still do the [array
# get] as this gives a sufficiently-consistent trace.
set opt [lindex $args 0]
if {[dict exists [array get options] $opt]} {
# Actually set the new value of the option. Use a catch to
# allow a megawidget user to throw an error from a write trace
# on the options array to reject invalid values.
try {
array set options $args
} on error {ret info} {
# Rethrow the error to get a clean stack trace
return -code error -errorcode [dict get $info -errorcode] $ret
}
return
}
} elseif {$argc % 2 == 0} {
# Check that all specified options exist. Any unknown option will
# cause the merged dictionary to be bigger than the options array
set merge [dict merge [array get options] $args]
if {[dict size $merge] == [array size options]} {
# Actually set the new values of the options. Use a catch to
# allow a megawidget user to throw an error from a write trace
# on the options array to reject invalid values
try {
array set options $args
} on error {ret info} {
# Rethrow the error to get a clean stack trace
return -code error -errorcode [dict get $info -errorcode] $ret
}
return
}
# Due to the order of the merge, the unknown options will be at
# the end of the dict. This makes the first unknown option easy to
# find.
set opt [lindex [dict keys $merge] [array size options]]
} else {
set opt [lindex $args end]
return -code error -errorcode [list TK VALUE_MISSING] \
"value for \"$opt\" missing"
}
return -code error -errorcode [list TK LOOKUP OPTION $opt] \
"bad option \"$opt\": must be [tclListValidFlags options]"
}
####################################################################
#
# MegawidgetClass::cget --
#
# Implementation of 'cget' for megawidgets. Emulates the operation of
# the standard Tk cget method fairly closely.
#
# This method assumes that the 'options' array in the class holds all
# options; it is up to subclasses to set traces on that array if they
# want to respond to configuration reads.
#
# TODO: allow unambiguous abbreviations.
#
method cget option {
return $options($option)
}
####################################################################
#
# MegawidgetClass::TraceOption --
#
# Sets up the tracing of an element of the options variable.
#
method TraceOption {option method args} {
set callback [list my $method {*}$args]
trace add variable options($option) write [namespace code $callback]
}
####################################################################
#
# MegawidgetClass::GetSpecs --
#
# Return a list of descriptions of options supported by this
# megawidget. Each option is described by the 4-tuple list, consisting
# of the name of the option, the "option database" name, the "option
# database" class-name, and the default value of the option. These are
# the same values returned by calling the configure method of a widget,
# except without the current values of the options.
#
method GetSpecs {} {
return {
{-takefocus takeFocus TakeFocus {}}
}
}
####################################################################
#
# MegawidgetClass::CreateHull --
#
# Creates the real main widget of the megawidget. This is often a frame
# or toplevel widget, but isn't always (lightweight megawidgets might
# use a content widget directly).
#
# The name of the hull widget is given by the 'w' instance variable. The
# name should be written into the 'hull' instance variable. The command
# created by this method will be renamed.
#
method CreateHull {} {
return -code error -errorcode {TCL OO ABSTRACT_METHOD} \
"method must be overridden"
}
####################################################################
#
# MegawidgetClass::Create --
#
# Creates the content of the megawidget. The name of the widget to
# create the content in will be in the 'hull' instance variable.
#
method Create {} {
return -code error -errorcode {TCL OO ABSTRACT_METHOD} \
"method must be overridden"
}
####################################################################
#
# MegawidgetClass::WhenIdle --
#
# Arrange for a method to be called on the current instance when Tk is
# idle. Only one such method call per method will be queued; subsequent
# queuing actions before the callback fires will be silently ignored.
# The additional args will be passed to the callback, and the callbacks
# will be properly cancelled if the widget is destroyed.
#
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::SimpleWidget --
#
# Simple megawidget class that makes it easy create widgets that behave
# like a ttk widget. It creates the hull as a ttk::frame and maps the
# state manipulation methods of the overall megawidget to the equivalent
# operations on the ttk::frame.
#
::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)]
my TraceOption -cursor UpdateCursorOption
}
method UpdateCursorOption args {
$hull configure -cursor $options(-cursor)
}
# Not fixed names, so can't forward
method state args {
tailcall $hull state {*}$args
}
method instate args {
tailcall $hull instate {*}$args
}
}
####################################################################
#
# tk::FocusableWidget --
#
# Simple megawidget class that makes a ttk-like widget that has a focus
# ring.
#
::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
my TraceOption -cursor UpdateCursorOption
}
}
return
# Local Variables:
# mode: tcl
# fill-column: 78
# End: