TIP #324 IMPLEMENTATION

1 files changed, 398 insertions, 0 deletions

diff --git a/library/fontchooser.tcl b/library/fontchooser.tcl
new file mode 100644
index 0000000..290eebf
--- /dev/null
+++ b/library/fontchooser.tcl
@@ -0,0 +1,398 @@
+# fontchooser.tcl -
+#
+#	A themeable Tk font selection dialog. See TIP #324.
+#
+# Copyright (C) 2008 Keith Vetter
+# Copyright (C) 2008 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: fontchooser.tcl,v 1.1 2008/12/10 05:02:51 das Exp $
+
+namespace eval ::tk::fontchooser {
+    variable S
+
+    set S(W) .__tk__fontchooser
+    set S(fonts) [lsort -dictionary [font families]]
+    set S(styles) [list \
+                       [::msgcat::mc "Regular"] \
+                       [::msgcat::mc "Italic"] \
+                       [::msgcat::mc "Bold"] \
+                       [::msgcat::mc "Bold Italic"] \
+                      ]
+
+    set S(sizes) {8 9 10 11 12 14 16 18 20 22 24 26 28 36 48 72}
+    set S(strike) 0
+    set S(under) 0
+    set S(first) 1
+    set S(sampletext) [::msgcat::mc "AaBbYyZz01"]
+    set S(-parent) .
+    set S(-title) [::msgcat::mc "Font"]
+    set S(-font) {}
+    set S(-command) {}
+
+    # Canonical versions of font families, styles, etc. for easier searching
+    set S(fonts,lcase) {}
+    foreach font $S(fonts) { lappend S(fonts,lcase) [string tolower $font]}
+    set S(styles,lcase) {}
+    foreach style $S(styles) { lappend S(styles,lcase) [string tolower $style]}
+    set S(sizes,lcase) $S(sizes)
+
+    ::ttk::style layout FontchooserFrame {
+        Entry.field -sticky news -border true -children {
+            FontchooserFrame.padding -sticky news
+        }
+    }
+    bind [winfo class .] <<ThemeChanged>> \
+        [list +ttk::style layout FontchooserFrame \
+             [ttk::style layout FontchooserFrame]]
+
+    namespace ensemble create -map {
+        show ::tk::fontchooser::Show
+        hide ::tk::fontchooser::Hide
+        configure ::tk::fontchooser::Configure
+    }
+}
+
+proc ::tk::fontchooser::Show {} {
+    variable S
+    if {![winfo exists $S(W)]} {
+        Create
+        wm transient $S(W) [winfo toplevel $S(-parent)]
+        tk::PlaceWindow $S(W) widget $S(-parent)
+    }
+    wm deiconify $S(W)
+}
+
+proc ::tk::fontchooser::Hide {} {
+    variable S
+    wm withdraw $S(W)
+}
+
+proc ::tk::fontchooser::Configure {args} {
+    variable S
+
+    set specs {
+        {-parent "" "" .}
+        {-title "" "" " "}
+        {-font "" "" ""}
+        {-command "" "" ""}
+    }
+
+    if {[llength $args] == 1 && [string equal [lindex $args 0] "-visible"]} {
+        return [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}]
+    }
+
+    tclParseConfigSpec [namespace which -variable S] $specs "" $args
+    if {$S(-parent) ne "."} {
+	winfo toplevel $S(-parent)
+    }
+    if {[string trim $S(-title)] eq ""} {
+        set S(-title) [::msgcat::mc "Font"]
+    }
+    if {[winfo exists $S(W)] && [lsearch $args -font] != -1} {
+	Init $S(-font)
+	event generate $S(-parent) <<TkFontchooserFontChanged>>
+    }
+}
+
+proc ::tk::fontchooser::Create {} {
+    variable S
+    set windowName __tk__fontchooser
+    if {$S(-parent) eq "."} {
+        set S(W) .$windowName
+    } else {
+        set S(W) $S(-parent).$windowName
+    }
+
+    # Now build the dialog
+    if {![winfo exists $S(W)]} {
+        toplevel $S(W) -class TkFontDialog
+        if {[package provide tcltest] ne {}} {set ::tk_dialog $S(W)}
+        wm withdraw $S(W)
+        wm title $S(W) $S(-title)
+        wm transient $S(W) [winfo toplevel $S(-parent)]
+        wm geometry $S(W) 430x316
+
+        set outer [::ttk::frame $S(W).outer -padding {10 10}]
+        ::tk::AmpWidget ::ttk::label $S(W).font -text [::msgcat::mc "&Font:"]
+        ::tk::AmpWidget ::ttk::label $S(W).style -text [::msgcat::mc "Font st&yle:"]
+        ::tk::AmpWidget ::ttk::label $S(W).size -text [::msgcat::mc "&Size:"]
+        ttk::entry $S(W).efont -textvariable [namespace which -variable S](font)
+        ttk::entry $S(W).estyle -textvariable [namespace which -variable S](style)
+        ttk::entry $S(W).esize -textvariable [namespace which -variable S](size) \
+            -width 0 -validate key -validatecommand {string is double %P}
+
+        ttk_slistbox $S(W).lfonts -height 7 -exportselection 0 \
+            -selectmode browse -activestyle none \
+            -listvariable [namespace which -variable S](fonts)
+        ttk_slistbox $S(W).lstyles -width 5 -height 7 -exportselection 0 \
+            -selectmode browse -activestyle none \
+            -listvariable [namespace which -variable S](styles)
+        ttk_slistbox $S(W).lsizes -width 6 -height 7 -exportselection 0 \
+            -selectmode browse -activestyle none \
+            -listvariable [namespace which -variable S](sizes) \
+
+        set WE $S(W).effects
+        ::ttk::labelframe $WE -text [::msgcat::mc "Effects"]
+        ::tk::AmpWidget ::ttk::checkbutton $WE.strike \
+            -variable [namespace which -variable S](strike) \
+            -text [::msgcat::mc "Stri&keout"] \
+            -command [namespace code [list Click strike]]
+        ::tk::AmpWidget ::ttk::checkbutton $WE.under \
+            -variable [namespace which -variable S](under) \
+            -text [::msgcat::mc "&Underline"] \
+            -command [namespace code [list Click under]]
+
+        set bbox [::ttk::frame $S(W).bbox]
+        ::ttk::button $S(W).ok -text [::msgcat::mc OK] -default active\
+            -command [namespace code [list Done 1]]
+        ::ttk::button $S(W).cancel -text [::msgcat::mc Cancel] \
+            -command [namespace code [list Done 0]]
+        ::tk::AmpWidget ::ttk::button $S(W).apply -text [::msgcat::mc "&Apply"] \
+            -command [namespace code [list Apply]]
+        wm protocol $S(W) WM_DELETE_WINDOW [namespace code [list Done 0]]
+
+        bind $S(W) <Return> [namespace code [list Done 1]]
+        bind $S(W) <Escape> [namespace code [list Done 0]]
+        bind $S(W) <Map> [namespace code [list Visibility %W 1]]
+        bind $S(W) <Unmap> [namespace code [list Visibility %W 0]]
+        bind $S(W) <Destroy> [namespace code [list Visibility %W 0]]
+        bind $S(W).lfonts.list <<ListboxSelect>> [namespace code [list Click font]]
+        bind $S(W).lstyles.list <<ListboxSelect>> [namespace code [list Click style]]
+        bind $S(W).lsizes.list <<ListboxSelect>> [namespace code [list Click size]]
+        bind $S(W) <Alt-Key> [list ::tk::AltKeyInDialog $S(W) %A]
+        bind $S(W).font <<AltUnderlined>> [list ::focus $S(W).efont]
+        bind $S(W).style <<AltUnderlined>> [list ::focus $S(W).estyle]
+        bind $S(W).size <<AltUnderlined>> [list ::focus $S(W).esize]
+        bind $S(W).apply <<AltUnderlined>> [namespace code [list Apply]]
+        bind $WE.strike <<AltUnderlined>> [list $WE.strike invoke]
+        bind $WE.under <<AltUnderlined>> [list $WE.under invoke]
+
+        set WS $S(W).sample
+        ::ttk::labelframe $WS -text [::msgcat::mc "Sample"]
+        ::ttk::label $WS.sample -relief sunken -anchor center \
+            -textvariable [namespace which -variable S](sampletext)
+        set S(sample) $WS.sample
+        grid $WS.sample -sticky news -padx 8 -pady 6
+        grid rowconfigure $WS 0 -weight 1
+        grid columnconfigure $WS 0 -weight 1
+        grid propagate $WS 0
+
+        grid $S(W).ok     -in $bbox -sticky new -pady {0 2}
+        grid $S(W).cancel -in $bbox -sticky new -pady 2
+        grid $S(W).apply -in $bbox -sticky new -pady 2
+        grid columnconfigure $bbox 0 -weight 1
+
+        grid $WE.strike -sticky w -padx 10
+        grid $WE.under -sticky w -padx 10 -pady {0 30}
+        grid columnconfigure $WE 1 -weight 1
+
+        grid $S(W).font   x $S(W).style   x $S(W).size   x       -in $outer -sticky w
+        grid $S(W).efont  x $S(W).estyle  x $S(W).esize  x $bbox -in $outer -sticky ew
+        grid $S(W).lfonts x $S(W).lstyles x $S(W).lsizes x ^     -in $outer -sticky news
+        grid $WE          x $WS           - -            x ^     -in $outer -sticky news -pady {15 30}
+        grid configure $bbox -sticky n
+        grid columnconfigure $outer {1 3 5} -minsize 10
+        grid columnconfigure $outer {0 2 4} -weight 1
+
+        grid $outer -sticky news
+        grid rowconfigure $S(W) 0 -weight 1
+        grid columnconfigure $S(W) 0 -weight 1
+
+        Init $S(-font)
+
+        trace add variable [namespace which -variable S](size) \
+            write [namespace code [list Tracer]]
+        trace add variable [namespace which -variable S](style) \
+            write [namespace code [list Tracer]]
+        trace add variable [namespace which -variable S](font) \
+            write [namespace code [list Tracer]]
+    } else {
+        Init $S(-font)
+    }
+
+    return
+}
+
+# ::tk::fontchooser::Done --
+#
+#       Handles teardown of the dialog, calling -command if needed
+#
+# Arguments:
+#       ok              true if user pressed OK
+#
+proc ::tk::::fontchooser::Done {ok} {
+    variable S
+
+    if {! $ok} {
+        set S(result) ""
+    }
+    trace vdelete S(size) w [namespace code [list Tracer]]
+    trace vdelete S(style) w [namespace code [list Tracer]]
+    trace vdelete S(font) w [namespace code [list Tracer]]
+    destroy $S(W)
+    if {$ok && $S(-command) ne ""} {
+        uplevel #0 $S(-command) [list $S(result)]
+    }
+}
+
+# ::tk::fontchooser::Apply --
+#
+#	Call the -command procedure appending the current font
+#	Errors are reported via the background error mechanism
+#
+proc ::tk::fontchooser::Apply {} {
+    variable S
+    if {$S(-command) ne ""} {
+        if {[catch {uplevel #0 $S(-command) [list $S(result)]} err]} {
+            ::bgerror $err
+        }
+    }
+    event generate $S(-parent) <<TkFontchooserFontChanged>>
+}
+
+# ::tk::fontchooser::Init --
+#
+#       Initializes dialog to a default font
+#
+# Arguments:
+#       defaultFont     font to use as the default
+#
+proc ::tk::fontchooser::Init {{defaultFont ""}} {
+    variable S
+
+    if {$S(first) || $defaultFont ne ""} {
+        if {$defaultFont eq ""} {
+            set defaultFont [[entry .___e] cget -font]
+            destroy .___e
+        }
+        array set F [font actual $defaultFont]
+        set S(font) $F(-family)
+        set S(size) $F(-size)
+        set S(strike) $F(-overstrike)
+        set S(under) $F(-underline)
+        set S(style) "Regular"
+        if {$F(-weight) eq "bold" && $F(-slant) eq "italic"} {
+            set S(style) "Bold Italic"
+        } elseif {$F(-weight) eq "bold"} {
+            set S(style) "Bold"
+        } elseif {$F(-slant) eq "italic"} {
+            set S(style) "Italic"
+        }
+
+        set S(first) 0
+    }
+
+    Tracer a b c
+    Update
+}
+
+# ::tk::fontchooser::Click --
+#
+#       Handles all button clicks, updating the appropriate widgets
+#
+# Arguments:
+#       who             which widget got pressed
+#
+proc ::tk::fontchooser::Click {who} {
+    variable S
+
+    if {$who eq "font"} {
+        set S(font) [$S(W).lfonts get [$S(W).lfonts curselection]]
+    } elseif {$who eq "style"} {
+        set S(style) [$S(W).lstyles get [$S(W).lstyles curselection]]
+    } elseif {$who eq "size"} {
+        set S(size) [$S(W).lsizes get [$S(W).lsizes curselection]]
+    }
+    Update
+}
+
+# ::tk::fontchooser::Tracer --
+#
+#       Handles traces on key variables, updating the appropriate widgets
+#
+# Arguments:
+#       standard trace arguments (not used)
+#
+proc ::tk::fontchooser::Tracer {var1 var2 op} {
+    variable S
+
+    set bad 0
+    set nstate normal
+    # Make selection in each listbox
+    foreach var {font style size} {
+        set value [string tolower $S($var)]
+        $S(W).l${var}s selection clear 0 end
+        set n [lsearch -exact $S(${var}s,lcase) $value]
+        $S(W).l${var}s selection set $n
+        if {$n != -1} {
+            set S($var) [lindex $S(${var}s) $n]
+            $S(W).e$var icursor end
+            $S(W).e$var selection clear
+        } else {                                ;# No match, try prefix
+            # Size is weird: valid numbers are legal but don't display
+            # unless in the font size list
+            set n [lsearch -glob $S(${var}s,lcase) "$value*"]
+            set bad 1
+            if {$var ne "size" || ! [string is double -strict $value]} {
+                set nstate disabled
+            }
+        }
+        $S(W).l${var}s see $n
+    }
+    if {!$bad} { Update }
+    $S(W).ok config -state $nstate
+}
+
+# ::tk::fontchooser::Update --
+#
+#       Shows a sample of the currently selected font
+#
+proc ::tk::fontchooser::Update {} {
+    variable S
+
+    set S(result) [list $S(font) $S(size)]
+    if {$S(style) eq "Bold"} { lappend S(result) bold }
+    if {$S(style) eq "Italic"} { lappend S(result) italic }
+    if {$S(style) eq "Bold Italic"} { lappend S(result) bold italic}
+    if {$S(strike)} { lappend S(result) overstrike}
+    if {$S(under)} { lappend S(result) underline}
+
+    $S(sample) config -font $S(result)
+}
+
+# ::tk::fontchooser::Visibility --
+#
+#	Notify the parent when the dialog visibility changes
+#
+proc ::tk::fontchooser::Visibility {w visible} {
+    variable S
+    if {$w eq $S(W)} {
+        event generate $S(-parent) <<TkFontchooserVisibility>>
+    }
+}
+
+# ::tk::fontchooser::ttk_listbox --
+#
+#	Create a properly themed scrolled listbox.
+#	This is exactly right on XP but may need adjusting on other platforms.
+#
+proc ::tk::fontchooser::ttk_slistbox {w args} {
+    set f [ttk::frame $w -style FontchooserFrame -padding 2]
+    if {[catch {
+        listbox $f.list -relief flat -highlightthickness 0 -borderwidth 0 {*}$args
+        ttk::scrollbar $f.vs -command [list $f.list yview]
+        $f.list configure -yscrollcommand [list $f.vs set]
+        grid $f.list $f.vs -sticky news
+        grid rowconfigure $f 0 -weight 1
+        grid columnconfigure $f 0 -weight 1
+        interp hide {} $w
+        interp alias {} $w {} $f.list
+    } err]} {
+        destroy $f
+        return -code error $err
+    }
+    return $w
+}