diff options
author | hobbs <hobbs> | 2006-10-31 01:42:25 (GMT) |
---|---|---|
committer | hobbs <hobbs> | 2006-10-31 01:42:25 (GMT) |
commit | 397a2c9832bf618f26be267501cf49ab06a562ec (patch) | |
tree | 61d5e957eccfcba57b0dd27ebc73db085385834e /library/ttk | |
parent | 18d330543869e240c2bd12fc9fbb8d5027f5cad6 (diff) | |
download | tk-397a2c9832bf618f26be267501cf49ab06a562ec.zip tk-397a2c9832bf618f26be267501cf49ab06a562ec.tar.gz tk-397a2c9832bf618f26be267501cf49ab06a562ec.tar.bz2 |
* doc/ttk_Geometry.3, doc/ttk_Theme.3, doc/ttk_button.n:
* doc/ttk_checkbutton.n, doc/ttk_combobox.n, doc/ttk_dialog.n:
* doc/ttk_entry.n, doc/ttk_frame.n, doc/ttk_image.n:
* doc/ttk_intro.n, doc/ttk_label.n, doc/ttk_labelframe.n:
* doc/ttk_menubutton.n, doc/ttk_notebook.n, doc/ttk_panedwindow.n:
* doc/ttk_progressbar.n, doc/ttk_radiobutton.n, doc/ttk_scrollbar.n:
* doc/ttk_separator.n, doc/ttk_sizegrip.n, doc/ttk_style.n:
* doc/ttk_treeview.n, doc/ttk_widget.n,:
* generic/ttk/ttk.decls, generic/ttk/ttkBlink.c:
* generic/ttk/ttkButton.c, generic/ttk/ttkCache.c:
* generic/ttk/ttkClamTheme.c, generic/ttk/ttkClassicTheme.c:
* generic/ttk/ttkDecls.h, generic/ttk/ttkDefaultTheme.c:
* generic/ttk/ttkElements.c, generic/ttk/ttkEntry.c:
* generic/ttk/ttkFrame.c, generic/ttk/ttkImage.c:
* generic/ttk/ttkInit.c, generic/ttk/ttkLabel.c:
* generic/ttk/ttkLayout.c, generic/ttk/ttkManager.c:
* generic/ttk/ttkManager.h, generic/ttk/ttkNotebook.c:
* generic/ttk/ttkPanedwindow.c, generic/ttk/ttkProgress.c:
* generic/ttk/ttkScale.c, generic/ttk/ttkScroll.c:
* generic/ttk/ttkScrollbar.c, generic/ttk/ttkSeparator.c:
* generic/ttk/ttkSquare.c, generic/ttk/ttkState.c:
* generic/ttk/ttkStubInit.c, generic/ttk/ttkStubLib.c:
* generic/ttk/ttkTagSet.c, generic/ttk/ttkTheme.c:
* generic/ttk/ttkTheme.h, generic/ttk/ttkThemeInt.h:
* generic/ttk/ttkTrace.c, generic/ttk/ttkTrack.c:
* generic/ttk/ttkTreeview.c, generic/ttk/ttkWidget.c:
* generic/ttk/ttkWidget.h:
* library/demos/ttk_demo.tcl, library/demos/ttk_iconlib.tcl:
* library/demos/ttk_repeater.tcl:
* library/ttk/altTheme.tcl, library/ttk/aquaTheme.tcl:
* library/ttk/button.tcl, library/ttk/clamTheme.tcl:
* library/ttk/classicTheme.tcl, library/ttk/combobox.tcl:
* library/ttk/cursors.tcl, library/ttk/defaults.tcl:
* library/ttk/dialog.tcl, library/ttk/entry.tcl:
* library/ttk/fonts.tcl, library/ttk/icons.tcl:
* library/ttk/keynav.tcl, library/ttk/menubutton.tcl:
* library/ttk/notebook.tcl, library/ttk/panedwindow.tcl:
* library/ttk/progress.tcl, library/ttk/scale.tcl:
* library/ttk/scrollbar.tcl, library/ttk/sizegrip.tcl:
* library/ttk/treeview.tcl, library/ttk/ttk.tcl:
* library/ttk/utils.tcl, library/ttk/winTheme.tcl:
* library/ttk/xpTheme.tcl:
* macosx/ttkMacOSXTheme.c:
* tests/ttk/all.tcl, tests/ttk/bwidget.test, tests/ttk/combobox.test:
* tests/ttk/entry.test, tests/ttk/image.test:
* tests/ttk/labelframe.test, tests/ttk/layout.test:
* tests/ttk/misc.test, tests/ttk/notebook.test:
* tests/ttk/panedwindow.test, tests/ttk/progressbar.test:
* tests/ttk/scrollbar.test, tests/ttk/treetags.test:
* tests/ttk/treeview.test, tests/ttk/ttk.test, tests/ttk/validate.test:
* win/ttkWinMonitor.c, win/ttkWinTheme.c, win/ttkWinXPTheme.c:
First import of Ttk themed Tk widgets as branched from tile 0.7.8
* generic/tkInt.h, generic/tkWindow.c: add Ttk_Init call, copy
tk classic widgets to ::tk namespace.
* library/tk.tcl: add source of ttk/ttk.tcl, define $::ttk::library.
* unix/Makefile.in, win/Makefile.in: add Ttk build bits
* win/configure, win/configure.in: check for uxtheme.h (XP theme).
Diffstat (limited to 'library/ttk')
-rw-r--r-- | library/ttk/altTheme.tcl | 85 | ||||
-rw-r--r-- | library/ttk/aquaTheme.tcl | 60 | ||||
-rw-r--r-- | library/ttk/button.tcl | 85 | ||||
-rw-r--r-- | library/ttk/clamTheme.tcl | 119 | ||||
-rw-r--r-- | library/ttk/classicTheme.tcl | 94 | ||||
-rw-r--r-- | library/ttk/combobox.tcl | 360 | ||||
-rw-r--r-- | library/ttk/cursors.tcl | 35 | ||||
-rw-r--r-- | library/ttk/defaults.tcl | 95 | ||||
-rw-r--r-- | library/ttk/dialog.tcl | 272 | ||||
-rw-r--r-- | library/ttk/entry.tcl | 580 | ||||
-rw-r--r-- | library/ttk/fonts.tcl | 132 | ||||
-rw-r--r-- | library/ttk/icons.tcl | 105 | ||||
-rw-r--r-- | library/ttk/keynav.tcl | 163 | ||||
-rw-r--r-- | library/ttk/menubutton.tcl | 171 | ||||
-rw-r--r-- | library/ttk/notebook.tcl | 205 | ||||
-rw-r--r-- | library/ttk/panedwindow.tcl | 87 | ||||
-rw-r--r-- | library/ttk/progress.tcl | 51 | ||||
-rw-r--r-- | library/ttk/scale.tcl | 54 | ||||
-rw-r--r-- | library/ttk/scrollbar.tcl | 107 | ||||
-rw-r--r-- | library/ttk/sizegrip.tcl | 77 | ||||
-rw-r--r-- | library/ttk/treeview.tcl | 423 | ||||
-rw-r--r-- | library/ttk/ttk.tcl | 200 | ||||
-rw-r--r-- | library/ttk/utils.tcl | 234 | ||||
-rw-r--r-- | library/ttk/winTheme.tcl | 61 | ||||
-rw-r--r-- | library/ttk/xpTheme.tcl | 51 |
25 files changed, 3906 insertions, 0 deletions
diff --git a/library/ttk/altTheme.tcl b/library/ttk/altTheme.tcl new file mode 100644 index 0000000..71fe23b --- /dev/null +++ b/library/ttk/altTheme.tcl @@ -0,0 +1,85 @@ +# +# $Id: altTheme.tcl,v 1.1 2006/10/31 01:42:26 hobbs Exp $ +# +# Ttk widget set: Alternate theme +# + +namespace eval ttk::theme::alt { + + variable colors + array set colors { + -frame "#d9d9d9" + -darker "#c3c3c3" + -activebg "#ececec" + -disabledfg "#a3a3a3" + -selectbg "#4a6984" + -selectfg "#ffffff" + } + + namespace import -force ::ttk::style + style theme settings alt { + + style configure "." \ + -background $colors(-frame) \ + -foreground black \ + -troughcolor $colors(-darker) \ + -selectbackground $colors(-selectbg) \ + -selectforeground $colors(-selectfg) \ + -font TkDefaultFont \ + ; + + style map "." -background \ + [list disabled $colors(-frame) active $colors(-activebg)] ; + style map "." -foreground [list disabled $colors(-disabledfg)] ; + style map "." -embossed [list disabled 1] ; + + style configure TButton \ + -width -11 -padding "1 1" -relief raised -shiftrelief 1 \ + -highlightthickness 1 -highlightcolor $colors(-frame) + + style map TButton -relief { + {pressed !disabled} sunken + {active !disabled} raised + } -highlightcolor {alternate black} + + style configure TCheckbutton -indicatorcolor "#ffffff" -padding 2 + style configure TRadiobutton -indicatorcolor "#ffffff" -padding 2 + style map TCheckbutton -indicatorcolor \ + [list disabled $colors(-frame) pressed $colors(-frame)] + style map TRadiobutton -indicatorcolor \ + [list disabled $colors(-frame) pressed $colors(-frame)] + + style configure TMenubutton -width -11 -padding "3 3" -relief raised + + style configure TEntry -padding 1 + style map TEntry -fieldbackground \ + [list readonly $colors(-frame) disabled $colors(-frame)] + style configure TCombobox -padding 1 + style map TCombobox -fieldbackground \ + [list readonly $colors(-frame) disabled $colors(-frame)] + + style configure Toolbutton -relief flat -padding 2 + style map Toolbutton -relief \ + {disabled flat selected sunken pressed sunken active raised} + style map Toolbutton -background \ + [list pressed $colors(-darker) active $colors(-activebg)] + + style configure TScrollbar -relief raised + + style configure TLabelframe -relief groove -borderwidth 2 + + style configure TNotebook -tabmargins {2 2 1 0} + style configure TNotebook.Tab \ + -padding {4 2} -background $colors(-darker) + style map TNotebook.Tab \ + -background [list selected $colors(-frame)] \ + -expand [list selected {2 2 1 0}] \ + ; + + style configure TScale \ + -groovewidth 4 -troughrelief sunken \ + -sliderwidth raised -borderwidth 2 + style configure TProgressbar \ + -background $colors(-selectbg) -borderwidth 0 + } +} diff --git a/library/ttk/aquaTheme.tcl b/library/ttk/aquaTheme.tcl new file mode 100644 index 0000000..4b4ad5e --- /dev/null +++ b/library/ttk/aquaTheme.tcl @@ -0,0 +1,60 @@ +# +# $Id: aquaTheme.tcl,v 1.1 2006/10/31 01:42:26 hobbs Exp $ +# +# Ttk widget set: Aqua theme (OSX native look and feel) +# +# +# TODO: panedwindow sashes should be 9 pixels (HIG:Controls:Split Views) +# + +namespace eval ttk { + + style theme settings aqua { + + style configure . \ + -font System \ + -background White \ + -foreground Black \ + -selectbackground SystemHighlight \ + -selectforeground SystemHighlightText \ + -selectborderwidth 0 \ + -insertwidth 1 \ + ; + style map . \ + -foreground [list disabled "#a3a3a3" background "#a3a3a3"] \ + -selectbackground [list background "#c3c3c3" !focus "#c3c3c3"] \ + -selectforeground [list background "#a3a3a3" !focus "#000000"] \ + ; + + # Workaround for #1100117: + # Actually, on Aqua we probably shouldn't stipple images in + # disabled buttons even if it did work... + # + style configure . -stipple {} + + style configure TButton -padding {0 2} -width -6 + style configure Toolbutton -padding 4 + # See Apple HIG figs 14-63, 14-65 + style configure TNotebook -tabposition n -padding {20 12} + style configure TNotebook.Tab -padding {10 2 10 2} + + # Enable animation for ttk::progressbar widget: + style configure TProgressbar -period 100 -maxphase 255 + + # Modify the the default Labelframe layout to use generic text element + # instead of Labelframe.text; the latter erases the window background + # (@@@ this still isn't right... want to fill with background pattern) + + style layout TLabelframe { + Labelframe.border + text + } + # + # For Aqua, labelframe labels should appear outside the border, + # with a 14 pixel inset and 4 pixels spacing between border and label + # (ref: Apple Human Interface Guidelines / Controls / Grouping Controls) + # + style configure TLabelframe \ + -labeloutside true -labelmargins {14 0 14 4} + } +} diff --git a/library/ttk/button.tcl b/library/ttk/button.tcl new file mode 100644 index 0000000..ccc1fb4 --- /dev/null +++ b/library/ttk/button.tcl @@ -0,0 +1,85 @@ +# +# $Id: button.tcl,v 1.1 2006/10/31 01:42:26 hobbs Exp $ +# +# Bindings for Buttons, Checkbuttons, and Radiobuttons. +# +# Notes: <Button1-Leave>, <Button1-Enter> only control the "pressed" +# state; widgets remain "active" if the pointer is dragged out. +# This doesn't seem to be conventional, but it's a nice way +# to provide extra feedback while the grab is active. +# (If the button is released off the widget, the grab deactivates and +# we get a <Leave> event then, which turns off the "active" state) +# +# Normally, <ButtonRelease> and <ButtonN-Enter/Leave> events are +# delivered to the widget which received the initial <ButtonPress> +# event. However, Tk [grab]s (#1223103) and menu interactions +# (#1222605) can interfere with this. To guard against spurious +# <Button1-Enter> events, the <Button1-Enter> binding only sets +# the pressed state if the button is currently active. +# + +namespace eval ttk::button {} + +bind TButton <Enter> { %W instate !disabled {%W state active} } +bind TButton <Leave> { %W state !active } +bind TButton <Key-space> { ttk::button::activate %W } +bind TButton <<Invoke>> { ttk::button::activate %W } + +bind TButton <ButtonPress-1> \ + { %W instate !disabled { ttk::clickToFocus %W; %W state pressed } } +bind TButton <ButtonRelease-1> \ + { %W instate {pressed !disabled} { %W state !pressed; %W invoke } } +bind TButton <Button1-Leave> \ + { %W state !pressed } +bind TButton <Button1-Enter> \ + { %W instate {active !disabled} { %W state pressed } } + +# Checkbuttons and Radiobuttons have the same bindings as Buttons: +# +ttk::CopyBindings TButton TCheckbutton +ttk::CopyBindings TButton TRadiobutton + +# ...plus a few more: + +bind TRadiobutton <KeyPress-Up> { ttk::button::RadioTraverse %W -1 } +bind TRadiobutton <KeyPress-Down> { ttk::button::RadioTraverse %W +1 } + +# bind TCheckbutton <KeyPress-plus> { %W select } +# bind TCheckbutton <KeyPress-minus> { %W deselect } + +# activate -- +# Simulate a button press: temporarily set the state to 'pressed', +# then invoke the button. +# +proc ttk::button::activate {w} { + $w instate disabled { return } + set oldState [$w state pressed] + update idletasks; after 100 + $w state $oldState + $w invoke +} + +# RadioTraverse -- up/down keyboard traversal for radiobutton groups. +# Set focus to previous/next radiobutton in a group. +# A radiobutton group consists of all the radiobuttons with +# the same parent and -variable; this is a pretty good heuristic +# that works most of the time. +# +proc ttk::button::RadioTraverse {w dir} { + set group [list] + foreach sibling [winfo children [winfo parent $w]] { + if { [winfo class $sibling] eq "TRadiobutton" + && [$sibling cget -variable] eq [$w cget -variable] + && ![$sibling instate disabled] + } { + lappend group $sibling + } + } + + if {![llength $group]} { # Shouldn't happen, but can. + return + } + + set pos [expr {([lsearch -exact $group $w] + $dir) % [llength $group]}] + tk::TabToWindow [lindex $group $pos] +} diff --git a/library/ttk/clamTheme.tcl b/library/ttk/clamTheme.tcl new file mode 100644 index 0000000..76e24fe --- /dev/null +++ b/library/ttk/clamTheme.tcl @@ -0,0 +1,119 @@ +# +# $Id: clamTheme.tcl,v 1.1 2006/10/31 01:42:26 hobbs Exp $ +# +# Ttk widget set: "Clam" theme +# +# Inspired by the XFCE family of Gnome themes. +# + +namespace eval ttk::theme::clam { + + package provide ttk::theme::clam 0.0.1 + + variable colors ; array set colors { + -disabledfg "#999999" + + -frame "#dcdad5" + -dark "#cfcdc8" + -darker "#bab5ab" + -darkest "#9e9a91" + -lighter "#eeebe7" + -lightest "#ffffff" + -selectbg "#4a6984" + -selectfg "#ffffff" + } + + namespace import -force ::ttk::style + style theme settings clam { + + style configure "." \ + -background $colors(-frame) \ + -foreground black \ + -bordercolor $colors(-darkest) \ + -darkcolor $colors(-dark) \ + -lightcolor $colors(-lighter) \ + -troughcolor $colors(-darker) \ + -selectbackground $colors(-selectbg) \ + -selectforeground $colors(-selectfg) \ + -selectborderwidth 0 \ + -font TkDefaultFont \ + ; + + style map "." \ + -background [list disabled $colors(-frame) \ + active $colors(-lighter)] \ + -foreground [list disabled $colors(-disabledfg)] \ + -selectbackground [list !focus $colors(-darkest)] \ + -selectforeground [list !focus white] \ + ; + # -selectbackground [list !focus "#847d73"] + + style configure TButton -width -11 -padding 5 -relief raised + style map TButton \ + -background [list \ + disabled $colors(-frame) \ + pressed $colors(-darker) \ + active $colors(-lighter)] \ + -lightcolor [list pressed $colors(-darker)] \ + -darkcolor [list pressed $colors(-darker)] \ + -bordercolor [list alternate "#000000"] \ + ; + + style configure Toolbutton -padding 2 -relief flat + style map Toolbutton \ + -relief {disabled flat selected sunken pressed sunken active raised} \ + -background [list disabled $colors(-frame) \ + pressed $colors(-darker) \ + active $colors(-lighter)] \ + -lightcolor [list pressed $colors(-darker)] \ + -darkcolor [list pressed $colors(-darker)] \ + ; + + style configure TCheckbutton \ + -indicatorbackground "#ffffff" \ + -indicatormargin {1 1 4 1} \ + -padding 2 ; + style configure TRadiobutton \ + -indicatorbackground "#ffffff" \ + -indicatormargin {1 1 4 1} \ + -padding 2 ; + style map TCheckbutton -indicatorbackground \ + [list disabled $colors(-frame) pressed $colors(-frame)] + style map TRadiobutton -indicatorbackground \ + [list disabled $colors(-frame) pressed $colors(-frame)] + + style configure TMenubutton -width -11 -padding 5 -relief raised + + style configure TEntry -padding 1 -insertwidth 1 + style map TEntry \ + -background [list readonly $colors(-frame)] \ + -bordercolor [list focus $colors(-selectbg)] \ + -lightcolor [list focus "#6f9dc6"] \ + -darkcolor [list focus "#6f9dc6"] \ + ; + + style configure TCombobox -padding 1 -insertwidth 1 + style map TCombobox \ + -background [list active $colors(-lighter) \ + pressed $colors(-lighter)] \ + -fieldbackground [list {readonly focus} $colors(-selectbg) \ + readonly $colors(-frame)] \ + -foreground [list {readonly focus} $colors(-selectfg)] \ + ; + + style configure TNotebook.Tab -padding {6 2 6 2} + style map TNotebook.Tab \ + -padding [list selected {6 4 6 2}] \ + -background [list selected $colors(-frame) {} $colors(-darker)] \ + -lightcolor [list selected $colors(-lighter) {} $colors(-dark)] \ + ; + + style configure TLabelframe \ + -labeloutside true -labelmargins {0 0 0 4} \ + -borderwidth 2 -relief raised + + style configure TProgressbar -background $colors(-frame) + + style configure Sash -sashthickness 6 -gripcount 10 + } +} diff --git a/library/ttk/classicTheme.tcl b/library/ttk/classicTheme.tcl new file mode 100644 index 0000000..6376268 --- /dev/null +++ b/library/ttk/classicTheme.tcl @@ -0,0 +1,94 @@ +# +# $Id: classicTheme.tcl,v 1.1 2006/10/31 01:42:26 hobbs Exp $ +# +# Ttk widget set: Classic theme. +# Implements the classic Tk Motif-like look and feel. +# + +namespace eval ttk::theme::classic { + + font create TkClassicDefaultFont -family Helvetica -weight bold -size -12 + + variable colors; array set colors { + -frame "#d9d9d9" + -activebg "#ececec" + -troughbg "#c3c3c3" + -selectbg "#c3c3c3" + -selectfg "#000000" + -disabledfg "#a3a3a3" + -indicator "#b03060" + } + + namespace import -force ::ttk::style + style theme settings classic { + style configure "." \ + -font TkClassicDefaultFont \ + -background $colors(-frame) \ + -foreground black \ + -selectbackground $colors(-selectbg) \ + -selectforeground $colors(-selectfg) \ + -troughcolor $colors(-troughbg) \ + -indicatorcolor $colors(-frame) \ + -highlightcolor $colors(-frame) \ + -highlightthickness 1 \ + -selectborderwidth 1 \ + -insertwidth 2 \ + ; + + style map "." -background \ + [list disabled $colors(-frame) active $colors(-activebg)] + style map "." -foreground \ + [list disabled $colors(-disabledfg)] + + style map "." -highlightcolor [list focus black] + + style configure TButton -padding "3m 1m" -relief raised -shiftrelief 1 + style map TButton -relief [list {!disabled pressed} sunken] + + style configure TCheckbutton -indicatorrelief raised + style map TCheckbutton \ + -indicatorcolor [list \ + pressed $colors(-frame) selected $colors(-indicator)] \ + -indicatorrelief {selected sunken pressed sunken} \ + ; + + style configure TRadiobutton -indicatorrelief raised + style map TRadiobutton \ + -indicatorcolor [list \ + pressed $colors(-frame) selected $colors(-indicator)] \ + -indicatorrelief {selected sunken pressed sunken} \ + ; + + style configure TMenubutton -relief raised -padding "3m 1m" + + style configure TEntry -relief sunken -padding 1 -font TkTextFont + style map TEntry -fieldbackground \ + [list readonly $colors(-frame) disabled $colors(-frame)] + style configure TCombobox -padding 1 + style map TCombobox -fieldbackground \ + [list readonly $colors(-frame) disabled $colors(-frame)] + + style configure TLabelframe -borderwidth 2 -relief groove + + style configure TScrollbar -relief raised + style map TScrollbar -relief {{pressed !disabled} sunken} + + style configure TScale -sliderrelief raised + style map TScale -sliderrelief {{pressed !disabled} sunken} + + style configure TProgressbar -background SteelBlue + style configure TNotebook.Tab \ + -padding {3m 1m} \ + -background $colors(-troughbg) + style map TNotebook.Tab -background [list selected $colors(-frame)] + + # + # Toolbar buttons: + # + style configure Toolbutton -padding 2 -relief flat -shiftrelief 2 + style map Toolbutton -relief \ + {disabled flat selected sunken pressed sunken active raised} + style map Toolbutton -background \ + [list pressed $colors(-troughbg) active $colors(-activebg)] + } +} diff --git a/library/ttk/combobox.tcl b/library/ttk/combobox.tcl new file mode 100644 index 0000000..7df9f61 --- /dev/null +++ b/library/ttk/combobox.tcl @@ -0,0 +1,360 @@ +# +# $Id: combobox.tcl,v 1.1 2006/10/31 01:42:27 hobbs Exp $ +# +# Ttk widget set: combobox bindings. +# +# Each combobox $cb has a child $cb.popdown, which contains +# a listbox $cb.popdown.l and a scrollbar. The listbox -listvariable +# is set to a namespace variable, which is used to synchronize the +# combobox values with the listbox values. +# + +namespace eval ttk::combobox { + variable Values ;# Values($cb) is -listvariable of listbox widget + + variable State + set State(entryPress) 0 +} + +### Combobox bindings. +# +# Duplicate the Entry bindings, override if needed: +# + +ttk::CopyBindings TEntry TCombobox + +bind TCombobox <KeyPress-Down> { ttk::combobox::Post %W } +bind TCombobox <KeyPress-Escape> { ttk::combobox::Unpost %W } + +bind TCombobox <ButtonPress-1> { ttk::combobox::Press "" %W %x %y } +bind TCombobox <Shift-ButtonPress-1> { ttk::combobox::Press "s" %W %x %y } +bind TCombobox <Double-ButtonPress-1> { ttk::combobox::Press "2" %W %x %y } +bind TCombobox <Triple-ButtonPress-1> { ttk::combobox::Press "3" %W %x %y } +bind TCombobox <B1-Motion> { ttk::combobox::Drag %W %x } + +bind TCombobox <MouseWheel> { ttk::combobox::Scroll %W [expr {%D/-120}] } +if {[tk windowingsystem] eq "x11"} { + bind TCombobox <ButtonPress-4> { ttk::combobox::Scroll %W -1 } + bind TCombobox <ButtonPress-5> { ttk::combobox::Scroll %W 1 } +} + +bind TCombobox <<TraverseIn>> { ttk::combobox::TraverseIn %W } + +### Combobox listbox bindings. +# +bind ComboboxListbox <ButtonPress-1> { focus %W ; continue } +bind ComboboxListbox <ButtonRelease-1> { ttk::combobox::LBSelected %W } +bind ComboboxListbox <KeyPress-Return> { ttk::combobox::LBSelected %W } +bind ComboboxListbox <KeyPress-Escape> { ttk::combobox::LBCancel %W } +bind ComboboxListbox <KeyPress-Tab> { ttk::combobox::LBTab %W next } +bind ComboboxListbox <<PrevWindow>> { ttk::combobox::LBTab %W prev } +bind ComboboxListbox <Destroy> { ttk::combobox::LBCleanup %W } +# Default behavior is to follow selection on mouseover +bind ComboboxListbox <Motion> { + %W selection clear 0 end + %W activate @%x,%y + %W selection set @%x,%y +} + +# The combobox has a global grab active when the listbox is posted, +# but on Windows and OSX that doesn't prevent the user from interacting +# with other applications. We need to popdown the listbox when this happens. +# +# On OSX, the listbox gets a <Deactivate> event. This doesn't happen +# on Windows or X11, but it does get a <FocusOut> event. However on OSX +# in Tk 8.5, the listbox gets spurious <FocusOut> events when the listbox +# is posted (see #1349811). +# +# The following seems to work: +# + +switch -- [tk windowingsystem] { + win32 { + bind ComboboxListbox <FocusOut> { ttk::combobox::LBCancel %W } + } + aqua { + bind ComboboxListbox <Deactivate> { ttk::combobox::LBCancel %W } + } +} + +### Option database settings. +# + +if {[tk windowingsystem] eq "x11"} { + option add *TCombobox*Listbox.background white +} + +# The following ensures that the popdown listbox uses the same font +# as the combobox entry field (at least for the standard Ttk themes). +# +option add *TCombobox*Listbox.font TkTextFont + +### Binding procedures. +# + +## combobox::Press $mode $x $y -- +# ButtonPress binding for comboboxes. +# Either post/unpost the listbox, or perform Entry widget binding, +# depending on widget state and location of button press. +# +proc ttk::combobox::Press {mode w x y} { + variable State + set State(entryPress) [expr { + [$w instate {!readonly !disabled}] + && [string match *textarea [$w identify $x $y]] + }] + + if {$State(entryPress)} { + focus $w + switch -- $mode { + s { ttk::entry::Shift-Press $w $x ; # Shift } + 2 { ttk::entry::Select $w $x word ; # Double click} + 3 { ttk::entry::Select $w $x line ; # Triple click } + "" - + default { ttk::entry::Press $w $x } + } + } else { + TogglePost $w + } +} + +## combobox::Drag -- +# B1-Motion binding for comboboxes. +# If the initial ButtonPress event was handled by Entry binding, +# perform Entry widget drag binding; otherwise nothing. +# +proc ttk::combobox::Drag {w x} { + variable State + if {$State(entryPress)} { + ttk::entry::Drag $w $x + } +} + +## TraverseIn -- receive focus due to keyboard navigation +# For editable comboboxes, set the selection and insert cursor. +# +proc ttk::combobox::TraverseIn {w} { + $w instate {!readonly !disabled} { + $w selection range 0 end + $w icursor end + } +} + +## SelectEntry $cb $index -- +# Set the combobox selection in response to a user action. +# +proc ttk::combobox::SelectEntry {cb index} { + $cb current $index + $cb selection range 0 end + $cb icursor end + event generate $cb <<ComboboxSelected>> +} + +## Scroll -- Mousewheel binding +# +proc ttk::combobox::Scroll {cb dir} { + $cb instate disabled { return } + set max [llength [$cb cget -values]] + set current [$cb current] + incr current $dir + if {$max != 0 && $current == $current % $max} { + SelectEntry $cb $current + } +} + +## LBSelected $lb -- Activation binding for listbox +# Set the combobox value to the currently-selected listbox value +# and unpost the listbox. +# +proc ttk::combobox::LBSelected {lb} { + set cb [LBMaster $lb] + set selection [$lb curselection] + Unpost $cb + focus $cb + if {[llength $selection] == 1} { + SelectEntry $cb [lindex $selection 0] + } +} + +## LBCancel -- +# Unpost the listbox. +# +proc ttk::combobox::LBCancel {lb} { + Unpost [LBMaster $lb] +} + +## LBTab -- +# Tab key binding for combobox listbox: +# Set the selection, and navigate to next/prev widget. +# +proc ttk::combobox::LBTab {lb dir} { + set cb [LBMaster $lb] + switch -- $dir { + next { set newFocus [tk_focusNext $cb] } + prev { set newFocus [tk_focusPrev $cb] } + } + + if {$newFocus ne ""} { + LBSelected $lb + # The [grab release] call in [Unpost] queues events that later + # re-set the focus. [update] to make sure these get processed first: + update + tk::TabToWindow $newFocus + } +} + +## PopdownShell -- +# Returns the popdown shell widget associated with a combobox, +# creating it if necessary. +# +proc ttk::combobox::PopdownShell {cb} { + if {![winfo exists $cb.popdown]} { + set popdown [toplevel $cb.popdown -relief solid -bd 1] + wm withdraw $popdown + wm overrideredirect $popdown 1 + wm transient $popdown [winfo toplevel $cb] + + # XXX Until we have a proper native scrollbar on Aqua, use + # XXX the regular Tk one + if {[tk windowingsystem] eq "aqua"} { + scrollbar $popdown.sb -orient vertical \ + -command [list $popdown.l yview] + } else { + ttk::scrollbar $popdown.sb -orient vertical \ + -command [list $popdown.l yview] + } + listbox $popdown.l \ + -listvariable ttk::combobox::Values($cb) \ + -yscrollcommand [list $popdown.sb set] \ + -exportselection false \ + -selectmode browse \ + -borderwidth 2 -relief flat \ + -highlightthickness 0 \ + -activestyle none \ + ; + + bindtags $popdown.l \ + [list $popdown.l ComboboxListbox Listbox $popdown all] + + grid $popdown.l $popdown.sb -sticky news + grid columnconfigure $popdown 0 -weight 1 + grid rowconfigure $popdown 0 -weight 1 + } + return $cb.popdown +} + +## combobox::Post $cb -- +# Pop down the associated listbox. +# +proc ttk::combobox::Post {cb} { + variable State + variable Values + + # Don't do anything if disabled: + # + $cb instate disabled { return } + + # Run -postcommand callback: + # + uplevel #0 [$cb cget -postcommand] + + # Combobox is in 'pressed' state while listbox posted: + # + $cb state pressed + + set popdown [PopdownShell $cb] + set values [$cb cget -values] + set current [$cb current] + if {$current < 0} { + set current 0 ;# no current entry, highlight first one + } + set Values($cb) $values + $popdown.l selection clear 0 end + $popdown.l selection set $current + $popdown.l activate $current + $popdown.l see $current + # Should allow user to control listbox height + set height [llength $values] + if {$height > 10} { + set height 10 + } + $popdown.l configure -height $height + update idletasks + + # Position listbox (@@@ factor with menubutton::PostPosition + # + set x [winfo rootx $cb] + set y [winfo rooty $cb] + set w [winfo width $cb] + set h [winfo height $cb] + if {[tk windowingsystem] eq "aqua"} { + # Adjust for platform-specific bordering to ensure the box is + # directly under actual 'entry square' + set xoff 3 + set yoff 2 + incr x $xoff + set w [expr {$w - $xoff*2}] + } else { + set yoff 0 + } + + set H [winfo reqheight $popdown] + if {$y + $h + $H > [winfo screenheight $popdown]} { + set Y [expr {$y - $H - $yoff}] + } else { + set Y [expr {$y + $h - $yoff}] + } + wm geometry $popdown ${w}x${H}+${x}+${Y} + + # Post the listbox: + # + wm deiconify $popdown + raise $popdown + # @@@ Workaround for TrackElementState bug: + event generate $cb <ButtonRelease-1> + # /@@@ + ttk::globalGrab $cb + focus $popdown.l +} + +## combobox::Unpost $cb -- +# Unpost the listbox, restore focus to combobox widget. +# +proc ttk::combobox::Unpost {cb} { + $cb state !pressed + ttk::releaseGrab $cb + if {[winfo exists $cb.popdown]} { + wm withdraw $cb.popdown + } + focus $cb +} + +## combobox::TogglePost $cb -- +# Post the listbox if unposted, unpost otherwise. +# +proc ttk::combobox::TogglePost {cb} { + if {[$cb instate pressed]} { Unpost $cb } { Post $cb } +} + +## LBMaster $lb -- +# Return the combobox main widget that owns the listbox. +# +proc ttk::combobox::LBMaster {lb} { + winfo parent [winfo parent $lb] +} + +## LBCleanup $lb -- +# <Destroy> binding for combobox listboxes. +# Cleans up by unsetting the linked textvariable. +# +# Note: we can't just use { unset [%W cget -listvariable] } +# because the widget command is already gone when this binding fires). +# [winfo parent] still works, fortunately. +# + +proc ttk::combobox::LBCleanup {lb} { + variable Values + unset Values([LBMaster $lb]) +} + +#*EOF* diff --git a/library/ttk/cursors.tcl b/library/ttk/cursors.tcl new file mode 100644 index 0000000..a151194 --- /dev/null +++ b/library/ttk/cursors.tcl @@ -0,0 +1,35 @@ +# +# $Id: cursors.tcl,v 1.1 2006/10/31 01:42:27 hobbs Exp $ +# +# Ttk package: Symbolic cursor names. +# +# @@@ TODO: Figure out appropriate platform-specific cursors +# for the various functions. +# + +namespace eval ttk { + + variable Cursors + + switch -glob $::tcl_platform(platform) { + "windows" { + array set Cursors { + hresize sb_h_double_arrow + vresize sb_v_double_arrow + seresize size_nw_se + } + } + + "unix" - + * { + array set Cursors { + hresize sb_h_double_arrow + vresize sb_v_double_arrow + seresize bottom_right_corner + } + } + + } +} + +#*EOF* diff --git a/library/ttk/defaults.tcl b/library/ttk/defaults.tcl new file mode 100644 index 0000000..a370e65 --- /dev/null +++ b/library/ttk/defaults.tcl @@ -0,0 +1,95 @@ +# +# $Id: defaults.tcl,v 1.1 2006/10/31 01:42:27 hobbs Exp $ +# +# Ttk widget set: Default theme +# + +namespace eval ttk { + # XXX do we want to separate Tk version from theme version? + package provide ttk::theme::default $::tk_version + + variable colors + array set colors { + -frame "#d9d9d9" + -activebg "#ececec" + -selectbg "#4a6984" + -selectfg "#ffffff" + -darker "#c3c3c3" + -disabledfg "#a3a3a3" + -indicator "#4a6984" + } + + style theme settings default { + + style configure "." \ + -borderwidth 1 \ + -background $colors(-frame) \ + -foreground black \ + -troughcolor $colors(-darker) \ + -font TkDefaultFont \ + -selectborderwidth 1 \ + -selectbackground $colors(-selectbg) \ + -selectforeground $colors(-selectfg) \ + -insertwidth 1 \ + -indicatordiameter 10 \ + ; + + style map "." -background \ + [list disabled $colors(-frame) active $colors(-activebg)] + style map "." -foreground \ + [list disabled $colors(-disabledfg)] + + style configure TButton \ + -padding "3 3" -width -9 -relief raised -shiftrelief 1 + style map TButton -relief [list {!disabled pressed} sunken] + + style configure TCheckbutton \ + -indicatorcolor "#ffffff" -indicatorrelief sunken -padding 1 + style map TCheckbutton -indicatorcolor \ + [list pressed $colors(-activebg) selected $colors(-indicator)] + + style configure TRadiobutton \ + -indicatorcolor "#ffffff" -indicatorrelief sunken -padding 1 + style map TRadiobutton -indicatorcolor \ + [list pressed $colors(-activebg) selected $colors(-indicator)] + + style configure TMenubutton -relief raised -padding "10 3" + + style configure TEntry -relief sunken -fieldbackground white -padding 1 + style map TEntry -fieldbackground \ + [list readonly $colors(-frame) disabled $colors(-frame)] + + style configure TCombobox -arrowsize 12 -padding 1 + style map TCombobox -fieldbackground \ + [list readonly $colors(-frame) disabled $colors(-frame)] + + style configure TLabelframe -relief groove -borderwidth 2 + + style configure TScrollbar -width 12 -arrowsize 12 + style map TScrollbar -arrowcolor [list disabled $colors(-disabledfg)] + + style configure TScale -sliderrelief raised + style configure TProgressbar -background $colors(-selectbg) + + style configure TNotebook.Tab \ + -padding {4 2} -background $colors(-darker) + style map TNotebook.Tab -background [list selected $colors(-frame)] + + # + # Toolbar buttons: + # + style layout Toolbutton { + Toolbutton.border -children { + Toolbutton.padding -children { + Toolbutton.label + } + } + } + + style configure Toolbutton -padding 2 -relief flat + style map Toolbutton -relief \ + {disabled flat selected sunken pressed sunken active raised} + style map Toolbutton -background \ + [list pressed $colors(-darker) active $colors(-activebg)] + } +} diff --git a/library/ttk/dialog.tcl b/library/ttk/dialog.tcl new file mode 100644 index 0000000..cb3db47 --- /dev/null +++ b/library/ttk/dialog.tcl @@ -0,0 +1,272 @@ +# +# $Id: dialog.tcl,v 1.1 2006/10/31 01:42:27 hobbs Exp $ +# +# Copyright (c) 2005, Joe English. Freely redistributable. +# +# Ttk widget set: dialog boxes. +# +# TODO: option to keep dialog onscreen ("persistent" / "transient") +# TODO: accelerator keys. +# TODO: use message catalogs for button labels +# TODO: routines to selectively enable/disable individual command buttons +# TODO: use megawidgetoid API [$dlg dismiss] vs. [ttk::dialog::dismiss $dlg] +# TODO: MAYBE: option for app-modal dialogs +# TODO: MAYBE: [wm withdraw] dialog on dismiss instead of self-destructing +# + +namespace eval ttk::dialog { + + variable Config + # + # Spacing parameters: + # (taken from GNOME HIG 2.0, may need adjustment for other platforms) + # (textwidth just a guess) + # + set Config(margin) 12 ;# space between icon and text + set Config(interspace) 6 ;# horizontal space between buttons + set Config(sepspace) 24 ;# vertical space above buttons + set Config(textwidth) 400 ;# width of dialog box text (pixels) + + variable DialogTypes ;# map -type => list of dialog options + variable ButtonOptions ;# map button name => list of button options + + # stockButton -- define new built-in button + # + proc stockButton {button args} { + variable ButtonOptions + set ButtonOptions($button) $args + } + + # Built-in button types: + # + stockButton ok -text OK + stockButton cancel -text Cancel + stockButton yes -text Yes + stockButton no -text No + stockButton retry -text Retry + + # stockDialog -- define new dialog type. + # + proc stockDialog {type args} { + variable DialogTypes + set DialogTypes($type) $args + } + + # Built-in dialog types: + # + stockDialog ok \ + -icon info -buttons {ok} -default ok + stockDialog okcancel \ + -icon info -buttons {ok cancel} -default ok -cancel cancel + stockDialog retrycancel \ + -icon question -buttons {retry cancel} -cancel cancel + stockDialog yesno \ + -icon question -buttons {yes no} + stockDialog yesnocancel \ + -icon question -buttons {yes no cancel} -cancel cancel +} + +## ttk::dialog::nop -- +# Do nothing (used as a default callback command). +# +proc ttk::dialog::nop {args} { } + +## ttk::dialog -- dialog box constructor. +# +interp alias {} ttk::dialog {} ttk::dialog::Constructor + +proc ttk::dialog::Constructor {dlg args} { + upvar #0 $dlg D + variable Config + variable ButtonOptions + variable DialogTypes + + # + # Option processing: + # + array set defaults { + -title "" + -message "" + -detail "" + -command ttk::dialog::nop + -icon "" + -buttons {} + -labels {} + -default {} + -cancel {} + -parent #AUTO + } + + array set options [array get defaults] + + foreach {option value} $args { + if {$option eq "-type"} { + array set options $DialogTypes($value) + } elseif {![info exists options($option)]} { + set validOptions [join [lsort [array names options]] ", "] + return -code error \ + "Illegal option $option: must be one of $validOptions" + } + } + array set options $args + + # ... + # + array set buttonOptions [array get ::ttk::dialog::ButtonOptions] + foreach {button label} $options(-labels) { + lappend buttonOptions($button) -text $label + } + + # + # Initialize dialog private data: + # + foreach option {-command -message -detail} { + set D($option) $options($option) + } + + toplevel $dlg -class Dialog; wm withdraw $dlg + + # + # Determine default transient parent. + # + # NB: menus (including menubars) are considered toplevels, + # so skip over those. + # + if {$options(-parent) eq "#AUTO"} { + set parent [winfo toplevel [winfo parent $dlg]] + while {[winfo class $parent] eq "Menu" && $parent ne "."} { + set parent [winfo toplevel [winfo parent $parent]] + } + set options(-parent) $parent + } + + # + # Build dialog: + # + if {$options(-parent) ne ""} { + wm transient $dlg $options(-parent) + } + wm title $dlg $options(-title) + wm protocol $dlg WM_DELETE_WINDOW { } + + set f [ttk::frame $dlg.f] + + ttk::label $f.icon + if {$options(-icon) ne ""} { + $f.icon configure -image [ttk::stockIcon dialog/$options(-icon)] + } + ttk::label $f.message -textvariable ${dlg}(-message) \ + -font TkCaptionFont -wraplength $Config(textwidth)\ + -anchor w -justify left + ttk::label $f.detail -textvariable ${dlg}(-detail) \ + -font TkTextFont -wraplength $Config(textwidth) \ + -anchor w -justify left + + # + # Command buttons: + # + set cmd [ttk::frame $f.cmd] + set column 0 + grid columnconfigure $f.cmd 0 -weight 1 + + foreach button $options(-buttons) { + incr column + eval [linsert $buttonOptions($button) 0 ttk::button $cmd.$button] + $cmd.$button configure -command [list ttk::dialog::Done $dlg $button] + grid $cmd.$button -row 0 -column $column \ + -padx [list $Config(interspace) 0] -sticky ew + grid columnconfigure $cmd $column -uniform buttons + } + + if {$options(-default) ne ""} { + keynav::defaultButton $cmd.$options(-default) + focus $cmd.$options(-default) + } + if {$options(-cancel) ne ""} { + bind $dlg <KeyPress-Escape> \ + [list event generate $cmd.$options(-cancel) <<Invoke>>] + wm protocol $dlg WM_DELETE_WINDOW \ + [list event generate $cmd.$options(-cancel) <<Invoke>>] + } + + # + # Assemble dialog. + # + pack $f.cmd -side bottom -expand false -fill x \ + -pady [list $Config(sepspace) $Config(margin)] -padx $Config(margin) + + if {0} { + # GNOME and Apple HIGs say not to use separators. + # But in case we want them anyway: + # + pack [ttk::separator $f.sep -orient horizontal] \ + -side bottom -expand false -fill x \ + -pady [list $Config(sepspace) 0] \ + -padx $Config(margin) + } + + if {$options(-icon) ne ""} { + pack $f.icon -side left -anchor n -expand false \ + -pady $Config(margin) -padx $Config(margin) + } + + pack $f.message -side top -expand false -fill x \ + -padx $Config(margin) -pady $Config(margin) + if {$options(-detail) != ""} { + pack $f.detail -side top -expand false -fill x \ + -padx $Config(margin) + } + + # Client area goes here. + + pack $f -expand true -fill both + keynav::enableMnemonics $dlg + wm deiconify $dlg +} + +## ttk::dialog::clientframe -- +# Returns the widget path of the dialog client frame, +# creating and managing it if necessary. +# +proc ttk::dialog::clientframe {dlg} { + variable Config + set client $dlg.f.client + if {![winfo exists $client]} { + pack [ttk::frame $client] -side top -expand true -fill both \ + -pady $Config(margin) -padx $Config(margin) + lower $client ;# so it's first in keyboard traversal order + } + return $client +} + +## ttk::dialog::Done -- +# -command callback for dialog command buttons (internal) +# +proc ttk::dialog::Done {dlg button} { + upvar #0 $dlg D + set rc [catch [linsert $D(-command) end $button] result] + if {$rc == 1} { + return -code $rc -errorinfo $::errorInfo -errorcode $::errorCode $result + } elseif {$rc == 3 || $rc == 4} { + # break or continue -- don't dismiss dialog + return + } + dismiss $dlg +} + +## ttk::dialog::activate $dlg $button -- +# Simulate a button press. +# +proc ttk::dialog::activate {dlg button} { + event generate $dlg.f.cmd.$button <<Invoke>> +} + +## dismiss -- +# Dismiss the dialog (without invoking any actions). +# +proc ttk::dialog::dismiss {dlg} { + uplevel #0 [list unset $dlg] + destroy $dlg +} + +#*EOF* diff --git a/library/ttk/entry.tcl b/library/ttk/entry.tcl new file mode 100644 index 0000000..65fdf90 --- /dev/null +++ b/library/ttk/entry.tcl @@ -0,0 +1,580 @@ +# +# $Id: entry.tcl,v 1.1 2006/10/31 01:42:27 hobbs Exp $ +# +# DERIVED FROM: tk/library/entry.tcl r1.22 +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 2004, Joe English +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +namespace eval ttk { + namespace eval entry { + variable State + + set State(x) 0 + set State(selectMode) char + set State(anchor) 0 + set State(scanX) 0 + set State(scanIndex) 0 + set State(scanMoved) 0 + + # Button-2 scan speed is (scanNum/scanDen) characters + # per pixel of mouse movement. + # The standard Tk entry widget uses the equivalent of + # scanNum = 10, scanDen = average character width. + # I don't know why that was chosen. + # + set State(scanNum) 1 + set State(scanDen) 1 + set State(deadband) 3 ;# #pixels for mouse-moved deadband. + } +} + +### Bindings. +# +# Removed the following standard Tk bindings: +# +# <Control-Key-space>, <Control-Shift-Key-space>, +# <Key-Select>, <Shift-Key-Select>: +# Ttk entry widget doesn't use selection anchor. +# <Key-Insert>: +# Inserts PRIMARY selection (on non-Windows platforms). +# This is inconsistent with typical platform bindings. +# <Double-Shift-ButtonPress-1>, <Triple-Shift-ButtonPress-1>: +# These don't do the right thing to start with. +# <Meta-Key-b>, <Meta-Key-d>, <Meta-Key-f>, +# <Meta-Key-BackSpace>, <Meta-Key-Delete>: +# Judgment call. If <Meta> happens to be assigned to the Alt key, +# these could conflict with application accelerators. +# (Plus, who has a Meta key these days?) +# <Control-Key-t>: +# Another judgment call. If anyone misses this, let me know +# and I'll put it back. +# + +## Clipboard events: +# +bind TEntry <<Cut>> { ttk::entry::Cut %W } +bind TEntry <<Copy>> { ttk::entry::Copy %W } +bind TEntry <<Paste>> { ttk::entry::Paste %W } +bind TEntry <<Clear>> { ttk::entry::Clear %W } + +## Button1 bindings: +# Used for selection and navigation. +# +bind TEntry <ButtonPress-1> { ttk::entry::Press %W %x } +bind TEntry <Shift-ButtonPress-1> { ttk::entry::Shift-Press %W %x } +bind TEntry <Double-ButtonPress-1> { ttk::entry::Select %W %x word } +bind TEntry <Triple-ButtonPress-1> { ttk::entry::Select %W %x line } +bind TEntry <B1-Motion> { ttk::entry::Drag %W %x } + +bind TEntry <B1-Leave> { ttk::Repeatedly ttk::entry::AutoScroll %W } +bind TEntry <B1-Enter> { ttk::CancelRepeat } +bind TEntry <ButtonRelease-1> { ttk::CancelRepeat } + +bind TEntry <Control-ButtonPress-1> { + %W instate {!readonly !disabled} { %W icursor @%x ; focus %W } +} + +## Button2 bindings: +# Used for scanning and primary transfer. +# Note: ButtonRelease-2 is mapped to <<PasteSelection>> in tk.tcl. +# +bind TEntry <ButtonPress-2> { ttk::entry::ScanMark %W %x } +bind TEntry <B2-Motion> { ttk::entry::ScanDrag %W %x } +bind TEntry <ButtonRelease-2> { ttk::entry::ScanRelease %W %x } +bind TEntry <<PasteSelection>> { ttk::entry::ScanRelease %W %x } + +## Keyboard navigation bindings: +# +bind TEntry <Key-Left> { ttk::entry::Move %W prevchar } +bind TEntry <Key-Right> { ttk::entry::Move %W nextchar } +bind TEntry <Control-Key-Left> { ttk::entry::Move %W prevword } +bind TEntry <Control-Key-Right> { ttk::entry::Move %W nextword } +bind TEntry <Key-Home> { ttk::entry::Move %W home } +bind TEntry <Key-End> { ttk::entry::Move %W end } + +bind TEntry <Shift-Key-Left> { ttk::entry::Extend %W prevchar } +bind TEntry <Shift-Key-Right> { ttk::entry::Extend %W nextchar } +bind TEntry <Shift-Control-Key-Left> { ttk::entry::Extend %W prevword } +bind TEntry <Shift-Control-Key-Right> { ttk::entry::Extend %W nextword } +bind TEntry <Shift-Key-Home> { ttk::entry::Extend %W home } +bind TEntry <Shift-Key-End> { ttk::entry::Extend %W end } + +bind TEntry <Control-Key-slash> { %W selection range 0 end } +bind TEntry <Control-Key-backslash> { %W selection clear } + +bind TEntry <<TraverseIn>> { %W selection range 0 end; %W icursor end } + +## Edit bindings: +# +bind TEntry <KeyPress> { ttk::entry::Insert %W %A } +bind TEntry <Key-Delete> { ttk::entry::Delete %W } +bind TEntry <Key-BackSpace> { ttk::entry::Backspace %W } + +# Ignore all Alt, Meta, and Control keypresses unless explicitly bound. +# Otherwise, the <KeyPress> class binding will fire and insert the character. +# Ditto for Escape, Return, and Tab. +# +bind TEntry <Alt-KeyPress> {# nothing} +bind TEntry <Meta-KeyPress> {# nothing} +bind TEntry <Control-KeyPress> {# nothing} +bind TEntry <Key-Escape> {# nothing} +bind TEntry <Key-Return> {# nothing} +bind TEntry <Key-KP_Enter> {# nothing} +bind TEntry <Key-Tab> {# nothing} + +# Argh. Apparently on Windows, the NumLock modifier is interpreted +# as a Command modifier. +if {[tk windowingsystem] eq "aqua"} { + bind TEntry <Command-KeyPress> {# nothing} +} + +## Additional emacs-like bindings: +# +bind TEntry <Control-Key-a> { ttk::entry::Move %W home } +bind TEntry <Control-Key-b> { ttk::entry::Move %W prevchar } +bind TEntry <Control-Key-d> { ttk::entry::Delete %W } +bind TEntry <Control-Key-e> { ttk::entry::Move %W end } +bind TEntry <Control-Key-f> { ttk::entry::Move %W nextchar } +bind TEntry <Control-Key-h> { ttk::entry::Backspace %W } +bind TEntry <Control-Key-k> { %W delete insert end } + +### Clipboard procedures. +# + +## EntrySelection -- Return the selected text of the entry. +# Raises an error if there is no selection. +# +proc ttk::entry::EntrySelection {w} { + set entryString [string range [$w get] [$w index sel.first] \ + [expr {[$w index sel.last] - 1}]] + if {[$w cget -show] ne ""} { + return [string repeat [string index [$w cget -show] 0] \ + [string length $entryString]] + } + return $entryString +} + +## Paste -- Insert clipboard contents at current insert point. +# +proc ttk::entry::Paste {w} { + catch { + set clipboard [::tk::GetSelection $w CLIPBOARD] + PendingDelete $w + $w insert insert $clipboard + See $w insert + } +} + +## Copy -- Copy selection to clipboard. +# +proc ttk::entry::Copy {w} { + if {![catch {EntrySelection $w} selection]} { + clipboard clear -displayof $w + clipboard append -displayof $w $selection + } +} + +## Clear -- Delete the selection. +# +proc ttk::entry::Clear {w} { + catch { $w delete sel.first sel.last } +} + +## Cut -- Copy selection to clipboard then delete it. +# +proc ttk::entry::Cut {w} { + Copy $w; Clear $w +} + +### Navigation procedures. +# + +## ClosestGap -- Find closest boundary between characters. +# Returns the index of the character just after the boundary. +# +proc ttk::entry::ClosestGap {w x} { + set pos [$w index @$x] + set bbox [$w bbox $pos] + if {$x - [lindex $bbox 0] > [lindex $bbox 2]/2} { + incr pos + } + return $pos +} + +## See $index -- Make sure that the character at $index is visible. +# +proc ttk::entry::See {w {index insert}} { + update idletasks ;# ensure scroll data up-to-date + set c [$w index $index] + # @@@ OR: check [$w index left] / [$w index right] + if {$c < [$w index @0] || $c >= [$w index @[winfo width $w]]} { + $w xview $c + } +} + +## NextWord -- Find the next word position. +# Note: The "next word position" follows platform conventions: +# either the next end-of-word position, or the start-of-word +# position following the next end-of-word position. +# +set ::ttk::entry::State(startNext) \ + [string equal $tcl_platform(platform) "windows"] + +proc ttk::entry::NextWord {w start} { + variable State + set pos [tcl_endOfWord [$w get] [$w index $start]] + if {$pos >= 0 && $State(startNext)} { + set pos [tcl_startOfNextWord [$w get] $pos] + } + if {$pos < 0} { + return end + } + return $pos +} + +## PrevWord -- Find the previous word position. +# +proc ttk::entry::PrevWord {w start} { + set pos [tcl_startOfPreviousWord [$w get] [$w index $start]] + if {$pos < 0} { + return 0 + } + return $pos +} + +## RelIndex -- Compute character/word/line-relative index. +# +proc ttk::entry::RelIndex {w where {index insert}} { + switch -- $where { + prevchar { expr {[$w index $index] - 1} } + nextchar { expr {[$w index $index] + 1} } + prevword { PrevWord $w $index } + nextword { NextWord $w $index } + home { return 0 } + end { $w index end } + default { error "Bad relative index $index" } + } +} + +## Move -- Move insert cursor to relative location. +# Also clears the selection, if any, and makes sure +# that the insert cursor is visible. +# +proc ttk::entry::Move {w where} { + $w icursor [RelIndex $w $where] + $w selection clear + See $w insert +} + +### Selection procedures. +# + +## ExtendTo -- Extend the selection to the specified index. +# +# The other end of the selection (the anchor) is determined as follows: +# +# (1) if there is no selection, the anchor is the insert cursor; +# (2) if the index is outside the selection, grow the selection; +# (3) if the insert cursor is at one end of the selection, anchor the other end +# (4) otherwise anchor the start of the selection +# +# The insert cursor is placed at the new end of the selection. +# +# Returns: selection anchor. +# +proc ttk::entry::ExtendTo {w index} { + set index [$w index $index] + set insert [$w index insert] + + # Figure out selection anchor: + if {![$w selection present]} { + set anchor $insert + } else { + set selfirst [$w index sel.first] + set sellast [$w index sel.last] + + if { ($index < $selfirst) + || ($insert == $selfirst && $index <= $sellast) + } { + set anchor $sellast + } else { + set anchor $selfirst + } + } + + # Extend selection: + if {$anchor < $index} { + $w selection range $anchor $index + } else { + $w selection range $index $anchor + } + + $w icursor $index + return $anchor +} + +## Extend -- Extend the selection to a relative position, show insert cursor +# +proc ttk::entry::Extend {w where} { + ExtendTo $w [RelIndex $w $where] + See $w +} + +### Button 1 binding procedures. +# +# Double-clicking followed by a drag enters "word-select" mode. +# Triple-clicking enters "line-select" mode. +# + +## Press -- ButtonPress-1 binding. +# Set the insertion cursor, claim the input focus, set up for +# future drag operations. +# +proc ttk::entry::Press {w x} { + variable State + + $w icursor [ClosestGap $w $x] + $w selection clear + $w instate !disabled { focus $w } + + # Set up for future drag, double-click, or triple-click. + set State(x) $x + set State(selectMode) char + set State(anchor) [$w index insert] +} + +## Shift-Press -- Shift-ButtonPress-1 binding. +# Extends the selection, sets anchor for future drag operations. +# +proc ttk::entry::Shift-Press {w x} { + variable State + + focus $w + set anchor [ExtendTo $w @$x] + + set State(x) $x + set State(selectMode) char + set State(anchor) $anchor +} + +## Select $w $x $mode -- Binding for double- and triple- clicks. +# Selects a word or line (according to mode), +# and sets the selection mode for subsequent drag operations. +# +proc ttk::entry::Select {w x mode} { + variable State + set cur [ClosestGap $w $x] + + switch -- $mode { + word { WordSelect $w $cur $cur } + line { LineSelect $w $cur $cur } + char { # no-op } + } + + set State(anchor) $cur + set State(selectMode) $mode +} + +## Drag -- Button1 motion binding. +# +proc ttk::entry::Drag {w x} { + variable State + set State(x) $x + DragTo $w $x +} + +## DragTo $w $x -- Extend selection to $x based on current selection mode. +# +proc ttk::entry::DragTo {w x} { + variable State + + set cur [ClosestGap $w $x] + switch $State(selectMode) { + char { CharSelect $w $State(anchor) $cur } + word { WordSelect $w $State(anchor) $cur } + line { LineSelect $w $State(anchor) $cur } + } +} + +## AutoScroll +# Called repeatedly when the mouse is outside an entry window +# with Button 1 down. Scroll the window left or right, +# depending on where the mouse is, and extend the selection +# according to the current selection mode. +# +# TODO: AutoScroll should repeat faster (50ms) than normal autorepeat. +# TODO: Need a way for ttk::Repeat scripts to cancel themselves. +# +proc ttk::entry::AutoScroll {w} { + variable State + if {![winfo exists $w]} return + set x $State(x) + if {$x > [winfo width $w]} { + $w xview scroll 2 units + DragTo $w $x + } elseif {$x < 0} { + $w xview scroll -2 units + DragTo $w $x + } +} + +## CharSelect -- select characters between index $from and $to +# +proc ttk::entry::CharSelect {w from to} { + if {$to <= $from} { + $w selection range $to $from + } else { + $w selection range $from $to + } + $w icursor $to +} + +## WordSelect -- Select whole words between index $from and $to +# +proc ttk::entry::WordSelect {w from to} { + if {$to < $from} { + set first [WordBack [$w get] $to] + set last [WordForward [$w get] $from] + $w icursor $first + } else { + set first [WordBack [$w get] $from] + set last [WordForward [$w get] $to] + $w icursor $last + } + $w selection range $first $last +} + +## WordBack, WordForward -- helper routines for WordSelect. +# +proc WordBack {text index} { + if {[set pos [tcl_wordBreakBefore $text $index]] < 0} { return 0 } + return $pos +} +proc WordForward {text index} { + if {[set pos [tcl_wordBreakAfter $text $index]] < 0} { return end } + return $pos +} + +## LineSelect -- Select the entire line. +# +proc ttk::entry::LineSelect {w _ _} { + variable State + $w selection range 0 end + $w icursor end +} + +### Button 2 binding procedures. +# + +## ScanMark -- ButtonPress-2 binding. +# Marks the start of a scan or primary transfer operation. +# +proc ttk::entry::ScanMark {w x} { + variable State + set State(scanX) $x + set State(scanIndex) [$w index @0] + set State(scanMoved) 0 +} + +## ScanDrag -- Button2 motion binding. +# +proc ttk::entry::ScanDrag {w x} { + variable State + + set dx [expr {$State(scanX) - $x}] + if {abs($dx) > $State(deadband)} { + set State(scanMoved) 1 + } + set left [expr {$State(scanIndex) + ($dx*$State(scanNum))/$State(scanDen)}] + $w xview $left + + if {$left != [set newLeft [$w index @0]]} { + # We've scanned past one end of the entry; + # reset the mark so that the text will start dragging again + # as soon as the mouse reverses direction. + # + set State(scanX) $x + set State(scanIndex) $newLeft + } +} + +## ScanRelease -- Button2 release binding. +# Do a primary transfer if the mouse has not moved since the button press. +# +proc ttk::entry::ScanRelease {w x} { + variable State + if {!$State(scanMoved)} { + $w instate {!disabled !readonly} { + $w icursor [ClosestGap $w $x] + catch {$w insert insert [::tk::GetSelection $w PRIMARY]} + } + } +} + +### Insertion and deletion procedures. +# + +## PendingDelete -- Delete selection prior to insert. +# If the entry currently has a selection, delete it and +# set the insert position to where the selection was. +# Returns: 1 if pending delete occurred, 0 if nothing was selected. +# +proc ttk::entry::PendingDelete {w} { + if {[$w selection present]} { + $w icursor sel.first + $w delete sel.first sel.last + return 1 + } + return 0 +} + +## Insert -- Insert text into the entry widget. +# If a selection is present, the new text replaces it. +# Otherwise, the new text is inserted at the insert cursor. +# +proc ttk::entry::Insert {w s} { + if {$s eq ""} { return } + PendingDelete $w + $w insert insert $s + See $w insert +} + +## Backspace -- Backspace over the character just before the insert cursor. +# If there is a selection, delete that instead. +# If the new insert position is offscreen to the left, +# scroll to place the cursor at about the middle of the window. +# +proc ttk::entry::Backspace {w} { + if {[PendingDelete $w]} { + See $w + return + } + set x [expr {[$w index insert] - 1}] + if {$x < 0} { return } + + $w delete $x + + if {[$w index @0] >= [$w index insert]} { + set range [$w xview] + set left [lindex $range 0] + set right [lindex $range 1] + $w xview moveto [expr {$left - ($right - $left)/2.0}] + } +} + +## Delete -- Delete the character after the insert cursor. +# If there is a selection, delete that instead. +# +proc ttk::entry::Delete {w} { + if {![PendingDelete $w]} { + $w delete insert + } +} + +#*EOF* diff --git a/library/ttk/fonts.tcl b/library/ttk/fonts.tcl new file mode 100644 index 0000000..c3d4d50 --- /dev/null +++ b/library/ttk/fonts.tcl @@ -0,0 +1,132 @@ +# +# $Id: fonts.tcl,v 1.1 2006/10/31 01:42:27 hobbs Exp $ +# +# Ttk package: Font specifications. +# +# This file, [source]d from ttk.tcl when the package is loaded, +# sets up the following symbolic fonts based on the current platform: +# +# TkDefaultFont -- default for GUI items not otherwise specified +# TkTextFont -- font for user text (entry, listbox, others). [not in #145] +# TkHeadingFont -- headings (column headings, etc) [not in #145] +# TkCaptionFont -- dialog captions (primary text in alert dialogs, etc.) +# TkTooltipFont -- font to use for tooltip windows +# +# This is a temporary solution until TIP #145 is implemented. +# +# Symbolic fonts listed in TIP #145: +# +# TkDefaultFont -- the default for all GUI items not otherwise specified. +# TkFixedFont -- standard fixed width font [not used in Ttk] +# TkMenuFont -- used for menu items [not used in Ttk] +# TkCaptionFont -- used for window and dialog caption bars [different in Ttk] +# TkSmallCaptionFont -- captions on contained windows or tool dialogs [not used] +# TkIconFont -- font in use for icon captions [not used in Ttk] +# TkTooltipFont -- font to use for tooltip windows +# +# +# +++ Platform notes: +# +# Windows: +# The default system font changed from "MS Sans Serif" to "Tahoma" +# in Windows XP/Windows 2000. +# +# MS documentation says to use "Tahoma 8" in Windows 2000/XP, +# although many MS programs still use "MS Sans Serif 8" +# +# Should use SystemParametersInfo() instead. +# +# Mac OSX / Aqua: +# Quoth the Apple HIG: +# The _system font_ (Lucida Grande Regular 13 pt) is used for text +# in menus, dialogs, and full-size controls. +# [...] Use the _view font_ (Lucida Grande Regular 12pt) as the default +# font of text in lists and tables. +# [...] Use the _emphasized system font_ (Lucida Grande Bold 13 pt) +# sparingly. It is used for the message text in alerts. +# [...] The _small system font_ (Lucida Grande Regular 11 pt) [...] +# is also the default font for column headings in lists, for help tags, +# and for small controls. +# +# Note that the font for column headings (TkHeadingFont) is +# _smaller_ than the +# +# There's also a GetThemeFont() Appearance Manager API call +# for looking up kThemeSystemFont dynamically. +# +# Mac classic: +# Don't know, can't find *anything* on the Web about Mac pre-OSX. +# Might have used Geneva. Doesn't matter, this platform +# isn't supported anymore anyway. +# +# X11: +# Need a way to tell if Xft is enabled or not. +# For now, assume patch #971980 applied. +# +# "Classic" look used Helvetica bold for everything except +# for entry widgets, which use Helvetica medium. +# Most other toolkits use medium weight for all UI elements, +# which is what we do now. +# +# Font size specified in pixels on X11, not points. +# This is Theoretically Wrong, but in practice works better; using +# points leads to huge inconsistencies across different servers. +# + +namespace eval ttk { + +catch {font create TkDefaultFont} +catch {font create TkTextFont} +catch {font create TkHeadingFont} +catch {font create TkCaptionFont} +catch {font create TkTooltipFont} + +switch -- [tk windowingsystem] { + win32 { + if {$tcl_platform(osVersion) >= 5.0} { + variable family "Tahoma" + } else { + variable family "MS Sans Serif" + } + variable size 8 + + font configure TkDefaultFont -family $family -size $size + font configure TkTextFont -family $family -size $size + font configure TkHeadingFont -family $family -size $size + font configure TkCaptionFont -family $family -size $size -weight bold + font configure TkTooltipFont -family $family -size $size + } + classic - + aqua { + variable family "Lucida Grande" + variable size 13 + variable viewsize 12 + variable smallsize 11 + + font configure TkDefaultFont -family $family -size $size + font configure TkTextFont -family $family -size $size + font configure TkHeadingFont -family $family -size $smallsize + font configure TkCaptionFont -family $family -size $size -weight bold + font configure TkTooltipFont -family $family -size $viewsize + } + x11 { + if {![catch {tk::pkgconfig get fontsystem} fs] && $fs eq "xft"} { + variable family "sans-serif" + } else { + variable family "Helvetica" + } + variable size -12 + variable ttsize -10 + variable capsize -14 + + font configure TkDefaultFont -family $family -size $size + font configure TkTextFont -family $family -size $size + font configure TkHeadingFont -family $family -size $size -weight bold + font configure TkCaptionFont -family $family -size $capsize -weight bold + font configure TkTooltipFont -family $family -size $ttsize + } +} + +} + +#*EOF* diff --git a/library/ttk/icons.tcl b/library/ttk/icons.tcl new file mode 100644 index 0000000..493bb0a --- /dev/null +++ b/library/ttk/icons.tcl @@ -0,0 +1,105 @@ +# +# $Id: icons.tcl,v 1.1 2006/10/31 01:42:27 hobbs Exp $ +# +# Ttk package -- stock icons. +# +# Usage: +# $w configure -image [ttk::stockIcon $context/$icon] +# +# At present, only includes icons for dialog boxes, +# dialog/info, dialog/warning, dialog/error, etc. +# +# This list should be expanded. +# +# See the Icon Naming Specification from the Tango project: +# http://standards.freedesktop.org/icon-naming-spec/ +# They've finally gotten around to publishing something. +# + +namespace eval ttk { + variable Icons ;# Map: icon name -> image + namespace eval icons {} ;# container namespace for images +} + +# stockIcon $name -- +# Returns a Tk image for built-in icon $name. +# +proc ttk::stockIcon {name} { + variable Icons + return $Icons($name) +} + +# defineImage -- +# Define a new stock icon. +# +proc ttk::defineImage {name args} { + variable Icons + set iconName ::ttk::icons::$name + eval [linsert $args 0 image create photo $iconName] + set Icons($name) $iconName +} + +# +# Stock icons for dialogs +# +# SOURCE: dialog icons taken from BWidget toolkit. +# +ttk::defineImage dialog/error -data { + R0lGODlhIAAgALMAAIQAAISEhPf/Mf8AAP////////////////////////// + /////////////////////yH5BAEAAAIALAAAAAAgACAAAASwUMhJBbj41s0n + HmAIYl0JiCgKlNWVvqHGnnA9mnY+rBytw4DAxhci2IwqoSdFaMKaSBFPQhxA + nahrdKS0MK8ibSoorBbBVvS4XNOKgey2e7sOmLPvGvkezsPtR3M2e3JzdFIB + gC9vfohxfVCQWI6PII1pkZReeIeWkzGJS1lHdV2bPy9koaKopUOtSatDfECq + phWKOra3G3YuqReJwiwUiRkZwsPEuMnNycslzrIdEQAAOw== +} + +ttk::defineImage dialog/info -data { + R0lGODlhIAAgALMAAAAAAAAA/4SEhMbGxvf/Mf////////////////////// + /////////////////////yH5BAEAAAQALAAAAAAgACAAAAStkMhJibj41s0n + HkUoDljXXaCoqqRgUkK6zqP7CvQQ7IGsAiYcjcejFYAb4ZAYMB4rMaeO51sN + kBKlc/uzRbng0NWlnTF3XAAZzExj2ET3BV7cqufctv2Tj0vvFn11RndkVSt6 + OYVZRmeDXRoTAGFOhTaSlDOWHACHW2MlHQCdYFebN6OkVqkZlzcXqTKWoS8w + GJMhs7WoIoC7v7i+v7uTwsO1o5HHu7TLtcodEQAAOw== +} + +ttk::defineImage dialog/question -data { + R0lGODlhIAAgALMAAAAAAAAA/4SEhMbGxvf/Mf////////////////////// + /////////////////////yH5BAEAAAQALAAAAAAgACAAAAS2kMhJibj41s0n + HkUoDljXXaCoqqRgUkK6zqP7CnS+AiY+D4GgUKbibXwrYEoYIIqMHmcoqGLS + BlBLzlrgzgC22FZYAJKvYG3ODPLS0khd+awDX+Qieh2Dnzb7dnE6VIAffYdl + dmo6bHiBFlJVej+PizRuXyUTAIxBkSGBNpuImZoVAJ9roSYAqH1Yqzetrkmz + GaI3F7MyoaYvHhicoLe/sk8axcnCisnKBczNxa3I0cW+1bm/EQAAOw== +} + +ttk::defineImage dialog/warning -data { + R0lGODlhIAAgALMAAAAAAISEAISEhMbGxv//AP////////////////////// + /////////////////////yH5BAEAAAUALAAAAAAgACAAAASrsMhJZ7g16y0D + IQPAjZr3gYBAroV5piq7uWcoxHJFv3eun0BUz9cJAmHElhFow8lcIQBgwHOu + aNJsDfk8ZgHH4TX4BW/Fo12ZjJ4Z10wuZ0cIZOny0jI6NTbnSwRaS3kUdCd2 + h0JWRYEhVIGFSoEfZo6FipRvaJkfUZB7cp2Cg5FDo6RSmn+on5qCPaivYTey + s4sqtqswp2W+v743whTCxcbHyG0FyczJEhEAADs= +} + +ttk::defineImage dialog/auth -data { + R0lGODlhIAAgAIQAAAAA/wAAAICAgICAAP///7CwsMDAwMjIAPjIAOjo6Pj4 + AODg4HBwcMj4ANjY2JiYANDQ0MjIyPj4yKCgoMiYAMjImDAwAMjIMJiYmJCQ + kAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAgACAAAAX+ICCOYmCa + ZKquZCCMQsDOqWC7NiAMvEyvAoLQVdgZCAfEAPWDERIJk8AwIJwUil5T91y4 + GC6ry4RoKH2zYGLhnS5tMUNAcaAvaUF2m1A9GeQIAQeDaEAECw6IJlVYAmAK + AWZJD3gEDpeXOwRYnHOCCgcPhTWWDhAQQYydkGYIoaOkp6h8m1ieSYOvP0ER + EQwEEap0dWagok1BswmMdbiursfIBHnBQs10oKF30tQ8QkISuAcB25UGQQ4R + EzzsA4MU4+WGBkXo6hMTMQADFQfwFtHmFSlCAEKEU2jc+YsHy8nAML4iJKzQ + Dx65hiWKTIA4pRC7CxblORRA8E/HFfxfQo4KUiBfPgL0SDbkV0ElKZcmEjwE + wqPCgwMiAQTASQDDzhkD4IkMkg+DiwU4aSTVQiIIBgFXE+ATsPHHCRVWM8QI + oJUrxi04TCzA0PQsWh9kMVx1u6UFA3116zLJGwIAOw== +} + +ttk::defineImage dialog/busy -data { + R0lGODlhIAAgALMAAAAAAIAAAACAAICAAAAAgIAAgACAgMDAwICAgP8AAAD/ + AP//AAAA//8A/wD//////yH5BAEAAAsALAAAAAAgACAAAASAcMlJq7046827 + /2AYBmRpkoC4BMlzvEkspypg3zitIsfjvgcEQifi+X7BoUpi9AGFxFATCV0u + eMEDQFu1GrdbpZXZC0e9LvF4gkifl8aX2tt7bIPvz/Q5l9btcn0gTWBJeR1G + bWBdO0EPPIuHHDmUSyxIMjM1lJVrnp+goaIfEQAAOw== +} + +#*EOF* diff --git a/library/ttk/keynav.tcl b/library/ttk/keynav.tcl new file mode 100644 index 0000000..090c8f5 --- /dev/null +++ b/library/ttk/keynav.tcl @@ -0,0 +1,163 @@ +######################################################################## +# keynav package - Enhanced keyboard navigation +# Copyright (C) 2003 Joe English +# Freely redistributable; see the file license.terms for details. +# +# $Id: keynav.tcl,v 1.1 2006/10/31 01:42:27 hobbs Exp $ +# +######################################################################## +# +# Usage: +# +# package require keynav +# +# keynav::enableMnemonics $toplevel -- +# Enable mnemonic accelerators for toplevel widget. Pressing Alt-K, +# where K is any alphanumeric key, will send an <<Invoke>> event to the +# widget with mnemonic K (as determined by the -underline and -text +# options). +# +# Side effects: adds a binding for <Alt-KeyPress> to $toplevel +# +# keynav::defaultButton $button -- +# Enables default activation for the toplevel window in which $button +# appears. Pressing <Key-Return> invokes the default widget. The +# default widget is set to the widget with keyboard focus if it is +# defaultable, otherwise $button. A widget is _defaultable_ if it has +# a -default option which is not set to "disabled". +# +# Side effects: adds <FocusIn> and <KeyPress-Return> bindings +# to the toplevel containing $button, and a <Destroy> binding +# to $button. +# +# $button must be a defaultable widget. +# + +namespace eval keynav {} + +package require Tcl 8.4 +package require Tk 8.4 +package provide keynav 1.0 + +event add <<Help>> <KeyPress-F1> + +# +# Bindings for stock Tk widgets: +# (NB: for 8.3 use tkButtonInvoke, tkMbPost instead) +# +bind Button <<Invoke>> { tk::ButtonInvoke %W } +bind Checkbutton <<Invoke>> { tk::ButtonInvoke %W } +bind Radiobutton <<Invoke>> { tk::ButtonInvoke %W } +bind Menubutton <<Invoke>> { tk::MbPost %W } + +proc keynav::enableMnemonics {w} { + bind [winfo toplevel $w] <Alt-KeyPress> {+ keynav::Alt-KeyPress %W %K } +} + +# mnemonic $w -- +# Return the mnemonic character for widget $w, +# as determined by the -text and -underline resources. +# +proc keynav::mnemonic {w} { + if {[catch { + set label [$w cget -text] + set underline [$w cget -underline] + }]} { return "" } + return [string index $label $underline] +} + +# FindMnemonic $w $key -- +# Locate the descendant of $w with mnemonic $key. +# +proc keynav::FindMnemonic {w key} { + if {[string length $key] != 1} { return } + set Q [list [set top [winfo toplevel $w]]] + while {[llength $Q]} { + set QN [list] + foreach w $Q { + if {[string equal -nocase $key [mnemonic $w]]} { + return $w + } + foreach c [winfo children $w] { + if {[winfo ismapped $c] && [winfo toplevel $c] eq $top} { + lappend QN $c + } + } + } + set Q $QN + } + return {} +} + +# Alt-KeyPress -- +# Alt-KeyPress binding for toplevels with mnemonic accelerators enabled. +# +proc keynav::Alt-KeyPress {w k} { + set w [FindMnemonic $w $k] + if {$w ne ""} { + event generate $w <<Invoke>> + return -code break + } +} + +# defaultButton $w -- +# Enable default activation for the toplevel containing $w, +# and make $w the default default widget. +# +proc keynav::defaultButton {w} { + variable DefaultButton + + $w configure -default active + set top [winfo toplevel $w] + set DefaultButton(current.$top) $w + set DefaultButton(default.$top) $w + + bind $w <Destroy> [list keynav::CleanupDefault $top] + bind $top <FocusIn> [list keynav::ClaimDefault $top %W] + bind $top <KeyPress-Return> [list keynav::ActivateDefault $top] +} + +proc keynav::CleanupDefault {top} { + variable DefaultButton + unset DefaultButton(current.$top) + unset DefaultButton(default.$top) +} + +# ClaimDefault $top $w -- +# <FocusIn> binding for default activation. +# Sets the default widget to $w if it is defaultable, +# otherwise set it to the default default. +# +proc keynav::ClaimDefault {top w} { + variable DefaultButton + if {![info exists DefaultButton(current.$top)]} { + # Someone destroyed the default default, but not + # the rest of the toplevel. + return; + } + + set default $DefaultButton(default.$top) + if {![catch {$w cget -default} dstate] && $dstate ne "disabled"} { + set default $w + } + + if {$default ne $DefaultButton(current.$top)} { + # Ignore errors -- someone may have destroyed the current default + catch { $DefaultButton(current.$top) configure -default normal } + $default configure -default active + set DefaultButton(current.$top) $default + } +} + +# ActivateDefault -- +# Invoke the default widget for toplevel window, if any. +# +proc keynav::ActivateDefault {top} { + variable DefaultButton + if {[info exists DefaultButton(current.$top)] + && [winfo exists $DefaultButton(current.$top)]} { + event generate $DefaultButton(current.$top) <<Invoke>> + } +} + +#*EOF* diff --git a/library/ttk/menubutton.tcl b/library/ttk/menubutton.tcl new file mode 100644 index 0000000..fec276e --- /dev/null +++ b/library/ttk/menubutton.tcl @@ -0,0 +1,171 @@ +# +# $Id: menubutton.tcl,v 1.1 2006/10/31 01:42:27 hobbs Exp $ +# +# Bindings for Menubuttons. +# +# Menubuttons have three interaction modes: +# +# Pulldown: Press menubutton, drag over menu, release to activate menu entry +# Popdown: Click menubutton to post menu +# Keyboard: <Key-space> or accelerator key to post menu +# +# (In addition, when menu system is active, "dropdown" -- menu posts +# on mouse-over. Ttk menubuttons don't implement this). +# +# For keyboard and popdown mode, we hand off to tk_popup and let +# the built-in Tk bindings handle the rest of the interaction. +# +# ON X11: +# +# Standard Tk menubuttons use a global grab on the menubutton. +# This won't work for Ttk menubuttons in pulldown mode, +# since we need to process the final <ButtonRelease> event, +# and this might be delivered to the menu. So instead we +# rely on the passive grab that occurs on <ButtonPress> events, +# and transition to popdown mode when the mouse is released +# or dragged outside the menubutton. +# +# ON WINDOWS: +# +# I'm not sure what the hell is going on here. [$menu post] apparently +# sets up some kind of internal grab for native menus. +# On this platform, just use [tk_popup] for all menu actions. +# +# ON MACOS: +# +# Same probably applies here. +# + +namespace eval ttk { + namespace eval menubutton { + variable State + array set State { + pulldown 0 + oldcursor {} + } + } +} + +bind TMenubutton <Enter> { %W instate !disabled {%W state active } } +bind TMenubutton <Leave> { %W state !active } +bind TMenubutton <Key-space> { ttk::menubutton::Popdown %W } +bind TMenubutton <<Invoke>> { ttk::menubutton::Popdown %W } + +if {[tk windowingsystem] eq "x11"} { + bind TMenubutton <ButtonPress-1> { ttk::menubutton::Pulldown %W } + bind TMenubutton <ButtonRelease-1> { ttk::menubutton::TransferGrab %W } + bind TMenubutton <B1-Leave> { ttk::menubutton::TransferGrab %W } +} else { + bind TMenubutton <ButtonPress-1> \ + { %W state pressed ; ttk::menubutton::Popdown %W } + bind TMenubutton <ButtonRelease-1> \ + { %W state !pressed } +} + +# PostPosition -- +# Returns the x and y coordinates where the menu +# should be posted, based on the menubutton and menu size +# and -direction option. +# +# TODO: adjust menu width to be at least as wide as the button +# for -direction above, below. +# +proc ttk::menubutton::PostPosition {mb menu} { + set x [winfo rootx $mb] + set y [winfo rooty $mb] + set dir [$mb cget -direction] + + set bw [winfo width $mb] + set bh [winfo height $mb] + set mw [winfo reqwidth $menu] + set mh [winfo reqheight $menu] + set sw [expr {[winfo screenwidth $menu] - $bw - $mw}] + set sh [expr {[winfo screenheight $menu] - $bh - $mh}] + + switch -- $dir { + above { if {$y >= $mh} { incr y -$mh } { incr y $bh } } + below { if {$y <= $sh} { incr y $bh } { incr y -$mh } } + left { if {$x >= $mw} { incr x -$mw } { incr x $bw } } + right { if {$x <= $sw} { incr x $bw } { incr x -$mw } } + flush { + # post menu atop menubutton. + # If there's a menu entry whose label matches the + # menubutton -text, assume this is an optionmenu + # and place that entry over the menubutton. + set index [FindMenuEntry $menu [$mb cget -text]] + if {$index ne ""} { + incr y -[$menu yposition $index] + } + } + } + + return [list $x $y] +} + +# Popdown -- +# Post the menu and set a grab on the menu. +# +proc ttk::menubutton::Popdown {mb} { + if {[$mb instate disabled] || [set menu [$mb cget -menu]] eq ""} { + return + } + foreach {x y} [PostPosition $mb $menu] { break } + tk_popup $menu $x $y +} + +# Pulldown (X11 only) -- +# Called when Button1 is pressed on a menubutton. +# Posts the menu; a subsequent ButtonRelease +# or Leave event will set a grab on the menu. +# +proc ttk::menubutton::Pulldown {mb} { + variable State + if {[$mb instate disabled] || [set menu [$mb cget -menu]] eq ""} { + return + } + foreach {x y} [PostPosition $mb $menu] { break } + set State(pulldown) 1 + set State(oldcursor) [$mb cget -cursor] + + $mb state pressed + $mb configure -cursor [$menu cget -cursor] + $menu post $x $y + tk_menuSetFocus $menu +} + +# TransferGrab (X11 only) -- +# Switch from pulldown mode (menubutton has an implicit grab) +# to popdown mode (menu has an explicit grab). +# +proc ttk::menubutton::TransferGrab {mb} { + variable State + if {$State(pulldown)} { + $mb configure -cursor $State(oldcursor) + $mb state {!pressed !active} + set State(pulldown) 0 + + set menu [$mb cget -menu] + tk_popup $menu [winfo rootx $menu] [winfo rooty $menu] + } +} + +# FindMenuEntry -- +# Hack to support tk_optionMenus. +# Returns the index of the menu entry with a matching -label, +# -1 if not found. +# +proc ttk::menubutton::FindMenuEntry {menu s} { + set last [$menu index last] + if {$last eq "none"} { + return "" + } + for {set i 0} {$i <= $last} {incr i} { + if {![catch {$menu entrycget $i -label} label] + && ($label eq $s)} { + return $i + } + } + return "" +} + +#*EOF* diff --git a/library/ttk/notebook.tcl b/library/ttk/notebook.tcl new file mode 100644 index 0000000..d2edddc --- /dev/null +++ b/library/ttk/notebook.tcl @@ -0,0 +1,205 @@ +# +# $Id: notebook.tcl,v 1.1 2006/10/31 01:42:27 hobbs Exp $ +# +# Bindings for TNotebook widget +# + +namespace eval ttk::notebook { + variable TLNotebooks ;# See enableTraversal +} + +bind TNotebook <ButtonPress-1> { ttk::notebook::Press %W %x %y } +bind TNotebook <Key-Right> { ttk::notebook::CycleTab %W 1; break } +bind TNotebook <Key-Left> { ttk::notebook::CycleTab %W -1; break } +bind TNotebook <Control-Key-Tab> { ttk::notebook::CycleTab %W 1; break } +bind TNotebook <Control-Shift-Key-Tab> { ttk::notebook::CycleTab %W -1; break } +catch { +bind TNotebook <Control-ISO_Left_Tab> { ttk::notebook::CycleTab %W -1; break } +} +bind TNotebook <Destroy> { ttk::notebook::Cleanup %W } + +# ActivateTab $nb $tab -- +# Select the specified tab and set focus. +# +# If $tab was already the current tab, set the focus to the +# notebook widget. Otherwise, set the focus to the first +# traversable widget in the pane. The behavior is that the +# notebook takes focus when the user selects the same tab +# a second time. This mirrors Windows tab behavior. +# +proc ttk::notebook::ActivateTab {w tab} { + if {[$w index $tab] eq [$w index current]} { + focus $w + } else { + $w select $tab + update ;# needed so focus logic sees correct mapped/unmapped states + if {[set f [ttk::focusFirst [$w select]]] ne ""} { + tk::TabToWindow $f + } + } +} + +# ttk::focusFirst $w -- +# Return the first descendant of $w, in preorder traversal order, +# that can take keyboard focus, "" if none do. +# +# See also: tk_focusNext +# +proc ttk::focusFirst {w} { + if {[ttk::takesFocus $w]} { + return $w + } + foreach child [winfo children $w] { + if {[set c [ttk::focusFirst $child]] ne ""} { + return $c + } + } + return "" +} + +# Press $nb $x $y -- +# ButtonPress-1 binding for notebook widgets. +# Activate the tab under the mouse cursor, if any. +# +proc ttk::notebook::Press {w x y} { + set index [$w index @$x,$y] + if {$index ne ""} { + ActivateTab $w $index + } +} + +# CycleTab -- +# Select the next/previous tab in the list. +# +proc ttk::notebook::CycleTab {w dir} { + if {[$w index end] != 0} { + set current [$w index current] + set select [expr {($current + $dir) % [$w index end]}] + while {[$w tab $select -state] != "normal" && ($select != $current)} { + set select [expr {($select + $dir) % [$w index end]}] + } + if {$select != $current} { + ActivateTab $w $select + } + } +} + +# MnemonicTab $nb $key -- +# Scan all tabs in the specified notebook for one with the +# specified mnemonic. If found, returns path name of tab; +# otherwise returns "" +# +proc ttk::notebook::MnemonicTab {nb key} { + set key [string toupper $key] + foreach tab [$nb tabs] { + set label [$nb tab $tab -text] + set underline [$nb tab $tab -underline] + set mnemonic [string toupper [string index $label $underline]] + if {$mnemonic ne "" && $mnemonic eq $key} { + return $tab + } + } + return "" +} + +# +++ Toplevel keyboard traversal. +# + +# enableTraversal -- +# Enable keyboard traversal for a notebook widget +# by adding bindings to the containing toplevel window. +# +# TLNotebooks($top) keeps track of the list of all traversal-enabled +# notebooks contained in the toplevel +# +proc ttk::notebook::enableTraversal {nb} { + variable TLNotebooks + + set top [winfo toplevel $nb] + + if {![info exists TLNotebooks($top)]} { + # Augment $top bindings: + # + bind $top <Control-Key-Tab> {+ttk::notebook::TLCycleTab %W 1} + bind $top <Shift-Control-Key-Tab> {+ttk::notebook::TLCycleTab %W -1} + catch { + bind $top <Control-Key-ISO_Left_Tab> {+ttk::notebook::TLCycleTab %W -1} + } + bind $top <Alt-KeyPress> \ + +[list ttk::notebook::MnemonicActivation $top %K] + bind $top <Destroy> {+ttk::notebook::TLCleanup %W} + } + + lappend TLNotebooks($top) $nb +} + +# TLCleanup -- <Destroy> binding for traversal-enabled toplevels +# +proc ttk::notebook::TLCleanup {w} { + variable TLNotebooks + if {$w eq [winfo toplevel $w]} { + unset -nocomplain -please TLNotebooks($w) + } +} + +# Cleanup -- <Destroy> binding for notebooks +# +proc ttk::notebook::Cleanup {nb} { + variable TLNotebooks + set top [winfo toplevel $nb] + if {[info exists TLNotebooks($top)]} { + set index [lsearch -exact $TLNotebooks($top) $nb] + set TLNotebooks($top) [lreplace $TLNotebooks($top) $index $index] + } +} + +# EnclosingNotebook $w -- +# Return the nearest traversal-enabled notebook widget +# that contains $w. +# +# BUGS: this only works properly for tabs that are direct children +# of the notebook widget. This routine should follow the +# geometry manager hierarchy, not window ancestry, but that +# information is not available in Tk. +# +proc ttk::notebook::EnclosingNotebook {w} { + variable TLNotebooks + + set top [winfo toplevel $w] + if {![info exists TLNotebooks($top)]} { return } + + while {$w ne $top && $w ne ""} { + if {[lsearch -exact $TLNotebooks($top) $w] >= 0} { + return $w + } + set w [winfo parent $w] + } + return "" +} + +# TLCycleTab -- +# toplevel binding procedure for Control-Tab / Shift-Control-Tab +# Select the next/previous tab in the nearest ancestor notebook. +# +proc ttk::notebook::TLCycleTab {w dir} { + set nb [EnclosingNotebook $w] + if {$nb ne ""} { + CycleTab $nb $dir + return -code break + } +} + +# MnemonicActivation $nb $key -- +# Alt-KeyPress binding procedure for mnemonic activation. +# Scan all notebooks in specified toplevel for a tab with the +# the specified mnemonic. If found, activate it and return TCL_BREAK. +# +proc ttk::notebook::MnemonicActivation {top key} { + variable TLNotebooks + foreach nb $TLNotebooks($top) { + if {[set tab [MnemonicTab $nb $key]] ne ""} { + ActivateTab $nb [$nb index $tab] + return -code break + } + } +} diff --git a/library/ttk/panedwindow.tcl b/library/ttk/panedwindow.tcl new file mode 100644 index 0000000..451e5c4 --- /dev/null +++ b/library/ttk/panedwindow.tcl @@ -0,0 +1,87 @@ +# +# $Id: panedwindow.tcl,v 1.1 2006/10/31 01:42:27 hobbs Exp $ +# +# Ttk widget set: bindings for TPanedwindow widget. +# + +namespace eval ttk::panedwindow { + variable State + array set State { + pressed 0 + pressX - + pressY - + sash - + sashPos - + } +} + +## Bindings: +# +bind TPanedwindow <ButtonPress-1> { ttk::panedwindow::Press %W %x %y } +bind TPanedwindow <B1-Motion> { ttk::panedwindow::Drag %W %x %y } +bind TPanedwindow <ButtonRelease-1> { ttk::panedwindow::Release %W %x %y } + +bind TPanedwindow <Motion> { ttk::panedwindow::SetCursor %W %x %y } +bind TPanedwindow <Enter> { ttk::panedwindow::SetCursor %W %x %y } +bind TPanedwindow <Leave> { ttk::panedwindow::ResetCursor %W } +# See PanedEventProc in ttkPanedwindow.c: +bind TPanedwindow <<EnteredChild>> { ttk::panedwindow::ResetCursor %W } + + +## Sash movement: +# +proc ttk::panedwindow::Press {w x y} { + variable State + + lassign [$w identify $x $y] sash element + if {![info exists sash]} { + set State(pressed) 0 + return + } + set State(pressed) 1 + set State(pressX) $x + set State(pressY) $y + set State(sash) $sash + set State(sashPos) [$w sashpos $sash] +} + +proc ttk::panedwindow::Drag {w x y} { + variable State + if {!$State(pressed)} { return } + switch -- [$w cget -orient] { + horizontal { set delta [expr {$x - $State(pressX)}] } + vertical { set delta [expr {$y - $State(pressY)}] } + } + $w sashpos $State(sash) [expr {$State(sashPos) + $delta}] +} + +proc ttk::panedwindow::Release {w x y} { + variable State + set State(pressed) 0 + SetCursor $w $x $y +} + +## Cursor management: +# +proc ttk::panedwindow::ResetCursor {w} { + variable State + if {!$State(pressed)} { + $w configure -cursor {} + } +} + +proc ttk::panedwindow::SetCursor {w x y} { + variable ::ttk::Cursors + + if {![llength [$w identify $x $y]]} { + ResetCursor $w + } else { + # Assume we're over a sash. + switch -- [$w cget -orient] { + horizontal { $w configure -cursor $Cursors(hresize) } + vertical { $w configure -cursor $Cursors(vresize) } + } + } +} + +#*EOF* diff --git a/library/ttk/progress.tcl b/library/ttk/progress.tcl new file mode 100644 index 0000000..f457bbe --- /dev/null +++ b/library/ttk/progress.tcl @@ -0,0 +1,51 @@ +# +# $Id: progress.tcl,v 1.1 2006/10/31 01:42:27 hobbs Exp $ +# +# Ttk widget set: progress bar utilities. +# + +namespace eval ttk::progressbar { + variable Timers ;# Map: widget name -> after ID +} + +# Autoincrement -- +# Periodic callback procedure for autoincrement mode +# +proc ttk::progressbar::Autoincrement {pb steptime stepsize} { + variable Timers + + if {![winfo exists $pb]} { + # widget has been destroyed -- cancel timer + unset -nocomplain Timers($pb) + return + } + + $pb step $stepsize + + set Timers($pb) [after $steptime \ + [list ttk::progressbar::Autoincrement $pb $steptime $stepsize] ] +} + +# ttk::progressbar::start -- +# Start autoincrement mode. Invoked by [$pb start] widget code. +# +proc ttk::progressbar::start {pb {steptime 50} {stepsize 1}} { + variable Timers + if {![info exists Timers($pb)]} { + Autoincrement $pb $steptime $stepsize + } +} + +# ttk::progressbar::stop -- +# Cancel autoincrement mode. Invoked by [$pb stop] widget code. +# +proc ttk::progressbar::stop {pb} { + variable Timers + if {[info exists Timers($pb)]} { + after cancel $Timers($pb) + unset Timers($pb) + } + $pb configure -value 0 +} + + diff --git a/library/ttk/scale.tcl b/library/ttk/scale.tcl new file mode 100644 index 0000000..2a5cf2e --- /dev/null +++ b/library/ttk/scale.tcl @@ -0,0 +1,54 @@ +# scale.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net> +# +# Bindings for the TScale widget +# +# $Id: scale.tcl,v 1.1 2006/10/31 01:42:27 hobbs Exp $ + +namespace eval ttk::scale { + variable State + array set State { + dragging 0 + } +} + +bind TScale <ButtonPress-1> { ttk::scale::Press %W %x %y } +bind TScale <B1-Motion> { ttk::scale::Drag %W %x %y } +bind TScale <ButtonRelease-1> { ttk::scale::Release %W %x %y } + +proc ttk::scale::Press {w x y} { + variable State + set State(dragging) 0 + + switch -glob -- [$w identify $x $y] { + *track - + *trough { + if {[$w get $x $y] <= [$w get]} { + ttk::Repeatedly Increment $w -1 + } else { + ttk::Repeatedly Increment $w 1 + } + } + *slider { + set State(dragging) 1 + set State(initial) [$w get] + } + } +} + +proc ttk::scale::Drag {w x y} { + variable State + if {$State(dragging)} { + $w set [$w get $x $y] + } +} + +proc ttk::scale::Release {w x y} { + variable State + set State(dragging) 0 + ttk::CancelRepeat +} + +proc ttk::scale::Increment {w delta} { + if {![winfo exists $w]} return + $w set [expr {[$w get] + $delta}] +} diff --git a/library/ttk/scrollbar.tcl b/library/ttk/scrollbar.tcl new file mode 100644 index 0000000..6b37b24 --- /dev/null +++ b/library/ttk/scrollbar.tcl @@ -0,0 +1,107 @@ +# +# $Id: scrollbar.tcl,v 1.1 2006/10/31 01:42:27 hobbs Exp $ +# +# Bindings for TScrollbar widget +# + +namespace eval ttk::scrollbar { + variable State + # State(xPress) -- + # State(yPress) -- initial position of mouse at start of drag. + # State(first) -- value of -first at start of drag. +} + +bind TScrollbar <ButtonPress-1> { ttk::scrollbar::Press %W %x %y } +bind TScrollbar <B1-Motion> { ttk::scrollbar::Drag %W %x %y } +bind TScrollbar <ButtonRelease-1> { ttk::scrollbar::Release %W %x %y } + +bind TScrollbar <ButtonPress-2> { ttk::scrollbar::Jump %W %x %y } +bind TScrollbar <B2-Motion> { ttk::scrollbar::Drag %W %x %y } +bind TScrollbar <ButtonRelease-2> { ttk::scrollbar::Release %W %x %y } + +proc ttk::scrollbar::Scroll {w n units} { + set cmd [$w cget -command] + if {$cmd ne ""} { + uplevel #0 $cmd scroll $n $units + } +} + +proc ttk::scrollbar::Moveto {w fraction} { + set cmd [$w cget -command] + if {$cmd ne ""} { + uplevel #0 $cmd moveto $fraction + } +} + +proc ttk::scrollbar::Press {w x y} { + variable State + + set State(xPress) $x + set State(yPress) $y + + switch -glob -- [$w identify $x $y] { + *uparrow - + *leftarrow { + ttk::Repeatedly Scroll $w -1 units + } + *downarrow - + *rightarrow { + ttk::Repeatedly Scroll $w 1 units + } + *thumb { + set State(first) [lindex [$w get] 0] + } + *trough { + set f [$w fraction $x $y] + if {$f < [lindex [$w get] 0]} { + # Clicked in upper/left trough + ttk::Repeatedly Scroll $w -1 pages + } elseif {$f > [lindex [$w get] 1]} { + # Clicked in lower/right trough + ttk::Repeatedly Scroll $w 1 pages + } else { + # Clicked on thumb (???) + set State(first) [lindex [$w get] 0] + } + } + } +} + +proc ttk::scrollbar::Drag {w x y} { + variable State + if {![info exists State(first)]} { + # Initial buttonpress was not on the thumb, + # or something screwy has happened. In either case, ignore: + return; + } + set xDelta [expr {$x - $State(xPress)}] + set yDelta [expr {$y - $State(yPress)}] + Moveto $w [expr {$State(first) + [$w delta $xDelta $yDelta]}] +} + +proc ttk::scrollbar::Release {w x y} { + variable State + unset -nocomplain State(xPress) State(yPress) State(first) + ttk::CancelRepeat +} + +# scrollbar::Jump -- ButtonPress-2 binding for scrollbars. +# Behaves exactly like scrollbar::Press, except that +# clicking in the trough jumps to the the selected position. +# +proc ttk::scrollbar::Jump {w x y} { + variable State + + switch -glob -- [$w identify $x $y] { + *thumb - + *trough { + set State(first) [$w fraction $x $y] + Moveto $w $State(first) + set State(xPress) $x + set State(yPress) $y + } + default { + Press $w $x $y + } + } +} diff --git a/library/ttk/sizegrip.tcl b/library/ttk/sizegrip.tcl new file mode 100644 index 0000000..f1b87b1 --- /dev/null +++ b/library/ttk/sizegrip.tcl @@ -0,0 +1,77 @@ +# +# $Id: sizegrip.tcl,v 1.1 2006/10/31 01:42:27 hobbs Exp $ +# +# Ttk widget set -- sizegrip widget bindings. +# +# Dragging a sizegrip widget resizes the containing toplevel. +# +# NOTE: the sizegrip widget must be in the lower right hand corner. +# + +option add *TSizegrip.cursor $::ttk::Cursors(seresize) + +namespace eval ttk::sizegrip { + variable State + array set State { + pressed 0 + pressX 0 + pressY 0 + width 0 + height 0 + widthInc 1 + heightInc 1 + toplevel {} + } +} + +bind TSizegrip <ButtonPress-1> { ttk::sizegrip::Press %W %X %Y } +bind TSizegrip <B1-Motion> { ttk::sizegrip::Drag %W %X %Y } +bind TSizegrip <ButtonRelease-1> { ttk::sizegrip::Release %W %X %Y } + +proc ttk::sizegrip::Press {W X Y} { + variable State + + set top [winfo toplevel $W] + + # Sanity-checks: + # If a negative X or Y position was specified for [wm geometry], + # just bail out -- there's no way to handle this cleanly. + # + if {[scan [wm geometry $top] "%dx%d+%d+%d" width height _x _y] != 4} { + return; + } + + # Account for gridded geometry: + # + set grid [wm grid $top] + if {[llength $grid]} { + set State(widthInc) [lindex $grid 2] + set State(heightInc) [lindex $grid 3] + } else { + set State(widthInc) [set State(heightInc) 1] + } + + set State(toplevel) $top + set State(pressX) $X + set State(pressY) $Y + set State(width) $width + set State(height) $height + set State(pressed) 1 +} + +proc ttk::sizegrip::Drag {W X Y} { + variable State + if {!$State(pressed)} { return } + set w [expr {$State(width) + ($X - $State(pressX))/$State(widthInc)}] + set h [expr {$State(height) + ($Y - $State(pressY))/$State(heightInc)}] + if {$w <= 0} { set w 1 } + if {$h <= 0} { set h 1 } + wm geometry $State(toplevel) ${w}x${h} +} + +proc ttk::sizegrip::Release {W X Y} { + variable State + set State(pressed) 0 +} + +#*EOF* diff --git a/library/ttk/treeview.tcl b/library/ttk/treeview.tcl new file mode 100644 index 0000000..265f34c --- /dev/null +++ b/library/ttk/treeview.tcl @@ -0,0 +1,423 @@ +# +# $Id: treeview.tcl,v 1.1 2006/10/31 01:42:27 hobbs Exp $ +# +# Ttk widget set -- bindings for Treeview widget. +# + +namespace eval ttk::treeview { + variable State + + # Enter/Leave/Motion + # + set State(activeWidget) {} + set State(activeHeading) {} + + # Press/drag/release: + # + set State(pressMode) none + set State(pressX) 0 + + # For pressMode == "resize" + set State(minWidth) 24 + set State(resizeColumn) #0 + set State(resizeWidth) 0 + + # For pressmode == "heading" + set State(heading) {} + + # Provide [lassign] if not already present + # (@@@ TODO: check if this is still needed after horrible-identify purge) + # + if {![llength [info commands lassign]]} { + proc lassign {vals args} { + uplevel 1 [list foreach $args $vals break] + } + } +} + +### Widget bindings. +# + +bind Treeview <Motion> { ttk::treeview::Motion %W %x %y } +bind Treeview <B1-Leave> { #nothing } +bind Treeview <Leave> { ttk::treeview::ActivateHeading {} {}} +bind Treeview <ButtonPress-1> { ttk::treeview::Press %W %x %y } +bind Treeview <Double-ButtonPress-1> { ttk::treeview::DoubleClick %W %x %y } +bind Treeview <ButtonRelease-1> { ttk::treeview::Release %W %x %y } +bind Treeview <B1-Motion> { ttk::treeview::Drag %W %x %y } +bind Treeview <KeyPress-Up> { ttk::treeview::Keynav %W up } +bind Treeview <KeyPress-Down> { ttk::treeview::Keynav %W down } +bind Treeview <KeyPress-Right> { ttk::treeview::Keynav %W right } +bind Treeview <KeyPress-Left> { ttk::treeview::Keynav %W left } +bind Treeview <KeyPress-Prior> { %W yview scroll -1 pages } +bind Treeview <KeyPress-Next> { %W yview scroll 1 pages } +bind Treeview <KeyPress-Return> { ttk::treeview::ToggleFocus %W } +bind Treeview <KeyPress-space> { ttk::treeview::ToggleFocus %W } + +bind Treeview <Shift-ButtonPress-1> \ + { ttk::treeview::Select %W %x %y extend } +bind Treeview <Control-ButtonPress-1> \ + { ttk::treeview::Select %W %x %y toggle } + +# Standard mousewheel bindings: +# +bind Treeview <MouseWheel> { %W yview scroll [expr {- (%D / 120) * 4}] units } +if {[string equal "x11" [tk windowingsystem]]} { + bind Treeview <ButtonPress-4> { %W yview scroll -5 units } + bind Treeview <ButtonPress-5> { %W yview scroll 5 units } +} + +### Binding procedures. +# + +## Keynav -- Keyboard navigation +# +# @@@ TODO: verify/rewrite up and down code. +# +proc ttk::treeview::Keynav {w dir} { + set focus [$w focus] + if {$focus eq ""} { return } + + switch -- $dir { + up { + if {[set up [$w prev $focus]] eq ""} { + set focus [$w parent $focus] + } else { + while {[$w item $up -open] && [llength [$w children $up]]} { + set up [lindex [$w children $up] end] + } + set focus $up + } + } + down { + if {[$w item $focus -open] && [llength [$w children $focus]]} { + set focus [lindex [$w children $focus] 0] + } else { + set up $focus + while {$up ne "" && [set down [$w next $up]] eq ""} { + set up [$w parent $up] + } + set focus $down + } + } + left { + if {[$w item $focus -open] && [llength [$w children $focus]]} { + CloseItem $w $focus + } else { + set focus [$w parent $focus] + } + } + right { + OpenItem $w $focus + } + } + + if {$focus != {}} { + SelectOp $w $focus choose + } +} + +## Motion -- pointer motion binding. +# Sets cursor, active element ... +# +proc ttk::treeview::Motion {w x y} { + variable ::ttk::Cursors + variable State + + set cursor {} + set activeHeading {} + + lassign [$w identify $x $y] what where detail + switch -- $what { + separator { set cursor $Cursors(hresize) } + heading { set activeHeading $where } + } + + if {[$w cget -cursor] ne $cursor} { + $w configure -cursor $cursor + } + ActivateHeading $w $activeHeading +} + +## ActivateHeading -- track active heading element +# +proc ttk::treeview::ActivateHeading {w heading} { + variable State + + if {$w != $State(activeWidget) || $heading != $State(activeHeading)} { + if {$State(activeHeading) != {}} { + $State(activeWidget) heading $State(activeHeading) state !active + } + if {$heading != {}} { + $w heading $heading state active + } + set State(activeHeading) $heading + set State(activeWidget) $w + } +} + +## Select $w $x $y $selectop +# Binding procedure for selection operations. +# See "Selection modes", below. +# +proc ttk::treeview::Select {w x y op} { + if {[set item [$w identify row $x $y]] ne "" } { + SelectOp $w $item $op + } +} + +## DoubleClick -- Double-ButtonPress-1 binding. +# +proc ttk::treeview::DoubleClick {w x y} { + if {[set row [$w identify row $x $y]] ne ""} { + Toggle $w $row + } else { + Press $w $x $y ;# perform single-click action + } +} + +## Press -- ButtonPress binding. +# +proc ttk::treeview::Press {w x y} { + lassign [$w identify $x $y] what where detail + focus $w ;# or: ClickToFocus? + + switch -- $what { + nothing { } + heading { heading.press $w $where } + separator { resize.press $w $x $where } + cell - + row - + item { SelectOp $w $where choose } + } + if {$what eq "item" && [string match *indicator $detail]} { + Toggle $w $where + } +} + +## Drag -- B1-Motion binding +# +proc ttk::treeview::Drag {w x y} { + variable State + switch $State(pressMode) { + resize { resize.drag $w $x } + heading { heading.drag $w $x $y } + } +} + +proc ttk::treeview::Release {w x y} { + variable State + switch $State(pressMode) { + resize { resize.release $w $x } + heading { heading.release $w } + } + set State(pressMode) none + Motion $w $x $y +} + +### Interactive column resizing. +# +# @@@ needs work. +# +proc ttk::treeview::resize.press {w x column} { + variable State + + set State(pressMode) "resize" + set State(pressX) $x + set State(resizeColumn) $column + set State(resizeWidth) [$w column $column -width] +} + +proc ttk::treeview::resize.drag {w x} { + variable State + set newWidth [expr {$State(resizeWidth) + $x - $State(pressX)}] + if {$newWidth < $State(minWidth)} { + set newWidth $State(minWidth) + } + $w column $State(resizeColumn) -width $newWidth +} + +proc ttk::treeview::resize.release {w x} { + # no-op +} + +### Heading activation. +# + +proc ttk::treeview::heading.press {w column} { + variable State + set State(pressMode) "heading" + set State(heading) $column + $w heading $column state pressed +} + +proc ttk::treeview::heading.drag {w x y} { + variable State + lassign [$w identify $x $y] what where detail + if {$what eq "heading" && $where eq $State(heading)} { + $w heading $State(heading) state pressed + } else { + $w heading $State(heading) state !pressed + } +} + +proc ttk::treeview::heading.release {w} { + variable State + if {[lsearch -exact [$w heading $State(heading) state] pressed] >= 0} { + after idle [$w heading $State(heading) -command] + } + $w heading $State(heading) state !pressed +} + +### Selection modes. +# + +## SelectOp $w $item [ choose | extend | toggle ] -- +# Dispatch to appropriate selection operation +# depending on current value of -selectmode. +# +proc ttk::treeview::SelectOp {w item op} { + select.$op.[$w cget -selectmode] $w $item +} + +## -selectmode none: +# +proc ttk::treeview::select.choose.none {w item} { $w focus $item } +proc ttk::treeview::select.toggle.none {w item} { $w focus $item } +proc ttk::treeview::select.extend.none {w item} { $w focus $item } + +## -selectmode browse: +# +proc ttk::treeview::select.choose.browse {w item} { BrowseTo $w $item } +proc ttk::treeview::select.toggle.browse {w item} { BrowseTo $w $item } +proc ttk::treeview::select.extend.browse {w item} { BrowseTo $w $item } + +## -selectmode multiple: +# +proc ttk::treeview::select.choose.extended {w item} { + BrowseTo $w $item +} +proc ttk::treeview::select.toggle.extended {w item} { + $w selection toggle $item +} +proc ttk::treeview::select.extend.extended {w item} { + if {[set anchor [$w focus]] ne ""} { + $w selection set [between $w $anchor $item] + } else { + BrowseTo $item + } +} + +### Tree structure utilities. +# + +## between $tv $item1 $item2 -- +# Returns a list of all items between $item1 and $item2, +# in preorder traversal order. $item1 and $item2 may be +# in either order. +# +# NOTES: +# This routine is O(N) in the size of the tree. +# There's probably a way to do this that's O(N) in the number +# of items returned, but I'm not clever enough to figure it out. +# +proc ttk::treeview::between {tv item1 item2} { + variable between [list] + variable selectingBetween 0 + ScanBetween $tv $item1 $item2 {} + return $between +} + +## ScanBetween -- +# Recursive worker routine for ttk::treeview::between +# +proc ttk::treeview::ScanBetween {tv item1 item2 item} { + variable between + variable selectingBetween + + if {$item eq $item1 || $item eq $item2} { + lappend between $item + set selectingBetween [expr {!$selectingBetween}] + } elseif {$selectingBetween} { + lappend between $item + } + foreach child [$tv children $item] { + ScanBetween $tv $item1 $item2 $child + } +} + +### User interaction utilities. +# + +## OpenItem, CloseItem -- Set the open state of an item, generate event +# + +proc ttk::treeview::OpenItem {w item} { + $w focus $item + event generate $w <<TreeviewOpen>> + $w item $item -open true +} + +proc ttk::treeview::CloseItem {w item} { + $w item $item -open false + $w focus $item + event generate $w <<TreeviewClose>> +} + +## Toggle -- toggle opened/closed state of item +# +proc ttk::treeview::Toggle {w item} { + if {[$w item $item -open]} { + CloseItem $w $item + } else { + OpenItem $w $item + } +} + +## ToggleFocus -- toggle opened/closed state of focus item +# +proc ttk::treeview::ToggleFocus {w} { + set item [$w focus] + if {$item ne ""} { + Toggle $w $item + } +} + +## BrowseTo -- navigate to specified item; set focus and selection +# +proc ttk::treeview::BrowseTo {w item} { + $w see $item + $w focus $item + $w selection set [list $item] +} + +### Style settings for selected built-in themes. +# +# Do this here instead of in the theme definitions since the details are +# likely to change; it's better to keep this all in one place for now. +# +namespace eval ::ttk::treeview { + variable theme + namespace import -force ::ttk::style + foreach theme [style theme names] { + style theme settings $theme { + style map Item -foreground [list selected "#FFFFFF"] + style configure Row -background "#EEEEEE" + style configure Heading -relief raised -font TkHeadingFont + style configure Item -justify left + style map Heading -relief { + pressed sunken + } + style map Row -background { + selected #4a6984 + focus #ccccff + alternate #FFFFFF + } + style map Cell -foreground { + selected #FFFFFF + } + } + } +} + +#*EOF* diff --git a/library/ttk/ttk.tcl b/library/ttk/ttk.tcl new file mode 100644 index 0000000..f573bfc --- /dev/null +++ b/library/ttk/ttk.tcl @@ -0,0 +1,200 @@ +# +# $Id: ttk.tcl,v 1.1 2006/10/31 01:42:27 hobbs Exp $ +# +# Ttk widget set initialization script. +# + +### Source library scripts. +# + +namespace eval ::ttk { + variable library + if {![info exists library]} { + set library [file dirname [info script]] + } +} + +source [file join $::ttk::library keynav.tcl] +source [file join $::ttk::library fonts.tcl] +source [file join $::ttk::library cursors.tcl] +source [file join $::ttk::library icons.tcl] +source [file join $::ttk::library utils.tcl] + +## ttk::deprecated $old $new -- +# Define $old command as a deprecated alias for $new command +# $old and $new must be fully namespace-qualified. +# +proc ::ttk::deprecated {old new} { + interp alias {} $old {} ttk::do'deprecate $old $new +} +## do'deprecate -- +# Implementation procedure for deprecated commands -- +# issue a warning (once), then re-alias old to new. +# +proc ::ttk::do'deprecate {old new args} { + deprecated'warning $old $new + interp alias {} $old {} $new + eval [linsert $args 0 $new] +} + +## deprecated'warning -- +# Gripe about use of deprecated commands. +# +proc ::ttk::deprecated'warning {old new} { + puts stderr "$old deprecated -- use $new instead" +} + +### Forward-compatibility. +# +# ttk::panedwindow used to be named ttk::paned. Keep the alias for now. +# +::ttk::deprecated ::ttk::paned ::ttk::panedwindow + +if {[info exists ::ttk::deprecrated] && $::ttk::deprecated} { + ### Deprecated bits. + # + + namespace eval ::tile { + # Deprecated namespace. Define these only when requested + variable library + if {![info exists library]} { + set library [file dirname [info script]] + } + + variable version 0.7.8 + variable patchlevel 0.7.8 + } + package provide tile $::tile::version + + ### Widgets. + # Widgets are all defined in the ::ttk namespace. + # + # For compatibility with earlier Tile releases, we temporarily + # create aliases ::tile::widget, and ::t$widget. + # Using any of the aliases will issue a warning. + # + + namespace eval ttk { + variable widgets { + button checkbutton radiobutton menubutton label entry + frame labelframe scrollbar + notebook progressbar combobox separator + scale + } + + variable wc + foreach wc $widgets { + namespace export $wc + + deprecated ::t$wc ::ttk::$wc + deprecated ::tile::$wc ::ttk::$wc + namespace eval ::tile [list namespace export $wc] + } + } +} + +### ::ttk::ThemeChanged -- +# Called from [::ttk::style theme use]. +# Sends a <<ThemeChanged>> virtual event to all widgets. +# +proc ::ttk::ThemeChanged {} { + set Q . + while {[llength $Q]} { + set QN [list] + foreach w $Q { + event generate $w <<ThemeChanged>> + foreach child [winfo children $w] { + lappend QN $child + } + } + set Q $QN + } +} + +### Public API. +# + +proc ::ttk::themes {{ptn *}} { + set themes [list] + + foreach pkg [lsearch -inline -all -glob [package names] ttk::theme::$ptn] { + lappend themes [namespace tail $pkg] + } + + return $themes +} + +## ttk::setTheme $theme -- +# Set the current theme to $theme, loading it if necessary. +# +proc ::ttk::setTheme {theme} { + variable currentTheme ;# @@@ Temp -- [::ttk::style theme use] doesn't work + if {$theme ni [::ttk::style theme names]} { + package require ttk::theme::$theme + } + ::ttk::style theme use $theme + set currentTheme $theme +} + +### Load widget bindings. +# +source [file join $::ttk::library button.tcl] +source [file join $::ttk::library menubutton.tcl] +source [file join $::ttk::library scrollbar.tcl] +source [file join $::ttk::library scale.tcl] +source [file join $::ttk::library progress.tcl] +source [file join $::ttk::library notebook.tcl] +source [file join $::ttk::library panedwindow.tcl] +source [file join $::ttk::library entry.tcl] +source [file join $::ttk::library combobox.tcl] ;# dependency: entry.tcl +source [file join $::ttk::library treeview.tcl] +source [file join $::ttk::library sizegrip.tcl] +source [file join $::ttk::library dialog.tcl] + +## Label and Labelframe bindings: +# (not enough to justify their own file...) +# +bind TLabelframe <<Invoke>> { tk::TabToWindow [tk_focusNext %W] } +bind TLabel <<Invoke>> { tk::TabToWindow [tk_focusNext %W] } + +### Load themes. +# +source [file join $::ttk::library defaults.tcl] +source [file join $::ttk::library classicTheme.tcl] +source [file join $::ttk::library altTheme.tcl] +source [file join $::ttk::library clamTheme.tcl] + +### Choose platform-specific default theme. +# +# Notes: +# + xpnative takes precedence over winnative if available. +# + On X11, users can use the X resource database to +# specify a preferred theme (*TkTheme: themeName) +# + +set ::ttk::defaultTheme "default" + +if {[package provide ttk::theme::winnative] != {}} { + source [file join $::ttk::library winTheme.tcl] + set ::ttk::defaultTheme "winnative" +} +if {[package provide ttk::theme::xpnative] != {}} { + source [file join $::ttk::library xpTheme.tcl] + set ::ttk::defaultTheme "xpnative" +} +if {[package provide ttk::theme::aqua] != {}} { + source [file join $::ttk::library aquaTheme.tcl] + set ::ttk::defaultTheme "aqua" +} + +set ::ttk::userTheme [option get . tkTheme TkTheme] +if {$::ttk::userTheme != {}} { + if {($::ttk::userTheme in [::ttk::style theme names]) + || ![catch {package require ttk::theme::$ttk::userTheme}]} { + set ::ttk::defaultTheme $::ttk::userTheme + } +} + +::ttk::setTheme $::ttk::defaultTheme + +#*EOF* diff --git a/library/ttk/utils.tcl b/library/ttk/utils.tcl new file mode 100644 index 0000000..b8059ae --- /dev/null +++ b/library/ttk/utils.tcl @@ -0,0 +1,234 @@ +# +# $Id: utils.tcl,v 1.1 2006/10/31 01:42:27 hobbs Exp $ +# +# Ttk widget set: utilities for widget implementations. +# + +### Focus management. +# + +## ttk::takefocus -- +# This is the default value of the "-takefocus" option +# for widgets that participate in keyboard navigation. +# +# See also: tk::FocusOK +# +proc ttk::takefocus {w} { + expr {[$w instate !disabled] && [winfo viewable $w]} +} + +## ttk::clickToFocus $w -- +# Utility routine, used in <ButtonPress-1> bindings -- +# Assign keyboard focus to the specified widget if -takefocus is enabled. +# +proc ttk::clickToFocus {w} { + if {[ttk::takesFocus $w]} { focus $w } +} + +## ttk::takesFocus w -- +# Test if the widget can take keyboard focus: +# +# + widget is viewable, AND: +# - if -takefocus is missing or empty, return 0, OR +# - if -takefocus is 0 or 1, return that value, OR +# - append the widget name to -takefocus and evaluate it +# as a script. +# +# See also: tk::FocusOK +# +# Note: This routine doesn't implement the same fallback heuristics +# as tk::FocusOK. +# +proc ttk::takesFocus {w} { + + if {![winfo viewable $w]} { return 0 } + + if {![catch {$w cget -takefocus} takefocus]} { + switch -- $takefocus { + 0 - + 1 { return $takefocus } + "" { return 0 } + default { + set value [uplevel #0 $takefocus [list $w]] + return [expr {$value eq 1}] + } + } + } + + return 0 +} + +### Grabs. +# +# Rules: +# Each call to [grabWindow $w] or [globalGrab $w] must be +# matched with a call to [releaseGrab $w] in LIFO order. +# +# Do not call [grabWindow $w] for a window that currently +# appears on the grab stack. +# +# See #1239190 and #1411983 for more discussion. +# +namespace eval ttk { + variable Grab ;# map: window name -> grab token + + # grab token details: + # Two-element list containing: + # 1) a script to evaluate to restore the previous grab (if any); + # 2) a script to evaluate to restore the focus (if any) +} + +## SaveGrab -- +# Record current grab and focus windows. +# +proc ttk::SaveGrab {w} { + variable Grab + + set restoreGrab [set restoreFocus ""] + + set grabbed [grab current $w] + if {[winfo exists $grabbed]} { + switch [grab status $grabbed] { + global { set restoreGrab [list grab -global $grabbed] } + local { set restoreGrab [list grab $grabbed] } + none { ;# grab window is really in a different interp } + } + } + + set focus [focus] + if {$focus ne ""} { + set restoreFocus [list focus -force $focus] + } + + set Grab($w) [list $restoreGrab $restoreFocus] +} + +## RestoreGrab -- +# Restore previous grab and focus windows. +# If called more than once without an intervening [SaveGrab $w], +# does nothing. +# +proc ttk::RestoreGrab {w} { + variable Grab + + if {![info exists Grab($w)]} { # Ignore + return; + } + + # The previous grab/focus window may have been destroyed, + # unmapped, or some other abnormal condition; ignore any errors. + # + foreach script $Grab($w) { + catch $script + } + + unset Grab($w) +} + +## ttk::grabWindow $w -- +# Records the current focus and grab windows, sets an application-modal +# grab on window $w. +# +proc ttk::grabWindow {w} { + SaveGrab $w + grab $w +} + +## ttk::globalGrab $w -- +# Same as grabWindow, but sets a global grab on $w. +# +proc ttk::globalGrab {w} { + SaveGrab $w + grab -global $w +} + +## ttk::releaseGrab -- +# Release the grab previously set by [ttk::grabWindow] +# or [ttk::globalGrab]. +# +proc ttk::releaseGrab {w} { + grab release $w + RestoreGrab $w +} + +### Auto-repeat. +# +# NOTE: repeating widgets do not have -repeatdelay +# or -repeatinterval resources as in standard Tk; +# instead a single set of settings is applied application-wide. +# (TODO: make this user-configurable) +# +# (@@@ Windows seems to use something like 500/50 milliseconds +# @@@ for -repeatdelay/-repeatinterval) +# + +namespace eval ttk { + variable Repeat + array set Repeat { + delay 300 + interval 100 + timer {} + script {} + } +} + +## ttk::Repeatedly -- +# Begin auto-repeat. +# +proc ttk::Repeatedly {args} { + variable Repeat + after cancel $Repeat(timer) + set script [uplevel 1 [list namespace code $args]] + set Repeat(script) $script + uplevel #0 $script + set Repeat(timer) [after $Repeat(delay) ttk::Repeat] +} + +## Repeat -- +# Continue auto-repeat +# +proc ttk::Repeat {} { + variable Repeat + uplevel #0 $Repeat(script) + set Repeat(timer) [after $Repeat(interval) ttk::Repeat] +} + +## ttk::CancelRepeat -- +# Halt auto-repeat. +# +proc ttk::CancelRepeat {} { + variable Repeat + after cancel $Repeat(timer) +} + +### Miscellaneous. +# + +## ttk::CopyBindings $from $to -- +# Utility routine; copies bindings from one bindtag onto another. +# +proc ttk::CopyBindings {from to} { + foreach event [bind $from] { + bind $to $event [bind $from $event] + } +} + +## ttk::LoadImages $imgdir ?$patternList? -- +# Utility routine for pixmap themes +# +# Loads all image files in $imgdir matching $patternList. +# Returns: a paired list of filename/imagename pairs. +# +proc ttk::LoadImages {imgdir {patterns {*.gif}}} { + foreach pattern $patterns { + foreach file [glob -directory $imgdir $pattern] { + set img [file tail [file rootname $file]] + if {![info exists images($img)]} { + set images($img) [image create photo -file $file] + } + } + } + return [array get images] +} + +#*EOF* diff --git a/library/ttk/winTheme.tcl b/library/ttk/winTheme.tcl new file mode 100644 index 0000000..ac4cba9 --- /dev/null +++ b/library/ttk/winTheme.tcl @@ -0,0 +1,61 @@ +# +# $Id: winTheme.tcl,v 1.1 2006/10/31 01:42:27 hobbs Exp $ +# +# Ttk widget set: Windows Native theme +# + +namespace eval ttk { + + style theme settings winnative { + + style configure "." \ + -background SystemButtonFace \ + -foreground SystemWindowText \ + -selectforeground SystemHighlightText \ + -selectbackground SystemHighlight \ + -troughcolor SystemScrollbar \ + -font TkDefaultFont \ + ; + + style map "." -foreground [list disabled SystemGrayText] ; + style map "." -embossed [list disabled 1] ; + + style configure TButton -width -11 -relief raised -shiftrelief 1 + style configure TCheckbutton -padding "2 4" + style configure TRadiobutton -padding "2 4" + style configure TMenubutton -padding "8 4" -arrowsize 3 -relief raised + + style map TButton -relief {{!disabled pressed} sunken} + + style configure TEntry \ + -padding 2 -selectborderwidth 0 -insertwidth 1 + style map TEntry \ + -fieldbackground \ + [list readonly SystemButtonFace disabled SystemButtonFace] \ + -selectbackground [list !focus SystemWindow] \ + -selectforeground [list !focus SystemWindowText] \ + ; + + style configure TCombobox -padding 2 + style map TCombobox \ + -selectbackground [list !focus SystemWindow] \ + -selectforeground [list !focus SystemWindowText] \ + -foreground [list {readonly focus} SystemHighlightText] \ + -focusfill [list {readonly focus} SystemHighlight] \ + ; + + style configure TLabelframe -borderwidth 2 -relief groove + + style configure Toolbutton -relief flat -padding {8 4} + style map Toolbutton -relief \ + {disabled flat selected sunken pressed sunken active raised} + + style configure TScale -groovewidth 4 + + style configure TNotebook -tabmargins {2 2 2 0} + style configure TNotebook.Tab -padding {3 1} -borderwidth 1 + style map TNotebook.Tab -expand [list selected {2 2 2 0}] + + style configure TProgressbar -borderwidth 0 -background SystemHighlight + } +} diff --git a/library/ttk/xpTheme.tcl b/library/ttk/xpTheme.tcl new file mode 100644 index 0000000..7749e56 --- /dev/null +++ b/library/ttk/xpTheme.tcl @@ -0,0 +1,51 @@ +# +# $Id: xpTheme.tcl,v 1.1 2006/10/31 01:42:27 hobbs Exp $ +# +# Ttk widget set: XP Native theme +# +# @@@ todo: spacing and padding needs tweaking + +namespace eval ttk { + + style theme settings xpnative { + + style configure . \ + -background SystemButtonFace \ + -foreground SystemWindowText \ + -selectforeground SystemHighlightText \ + -selectbackground SystemHighlight \ + -font TkDefaultFont \ + ; + + style map "." \ + -foreground [list disabled SystemGrayText] \ + ; + + style configure TButton -padding {1 1} -width -11 + style configure TRadiobutton -padding 2 + style configure TCheckbutton -padding 2 + style configure TMenubutton -padding {8 4} + + style configure TNotebook -tabmargins {2 2 2 0} + style map TNotebook.Tab \ + -expand [list selected {2 2 2 2}] + + style configure TLabelframe -foreground "#0046d5" + + # OR: -padding {3 3 3 6}, which some apps seem to use. + style configure TEntry -padding {2 2 2 4} + style map TEntry \ + -selectbackground [list !focus SystemWindow] \ + -selectforeground [list !focus SystemWindowText] \ + ; + style configure TCombobox -padding 2 + style map TCombobox \ + -selectbackground [list !focus SystemWindow] \ + -selectforeground [list !focus SystemWindowText] \ + -foreground [list {readonly focus} SystemHighlightText] \ + -focusfill [list {readonly focus} SystemHighlight] \ + ; + + style configure Toolbutton -padding {4 4} + } +} |