Edit: /usr/share/tk8.6/fontchooser.tcl (15840B)
# fontchooser.tcl -
#
# A themeable Tk font selection dialog. See TIP #324.
#
# Copyright (C) 2008 Keith Vetter
# Copyright (C) 2008 Pat Thoyts
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
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(-command) ""
set S(-font) TkDefaultFont
}
proc ::tk::fontchooser::Setup {} {
variable S
# 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 .] <> \
[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
}
}
::tk::fontchooser::Setup
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)
}
set S(fonts) [lsort -dictionary [font families]]
set S(fonts,lcase) {}
foreach font $S(fonts) { lappend S(fonts,lcase) [string tolower $font]}
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] == 0} {
set result {}
foreach spec $specs {
foreach {name xx yy default} $spec break
lappend result $name \
[expr {[info exists S($name)] ? $S($name) : $default}]
}
lappend result -visible \
[expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}]
return $result
}
if {[llength $args] == 1} {
set option [lindex $args 0]
if {[string equal $option "-visible"]} {
return [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}]
} elseif {[info exists S($option)]} {
return $S($option)
}
return -code error -errorcode [list TK LOOKUP OPTION $option] \
"bad option \"$option\": must be\
-command, -font, -parent, -title or -visible"
}
set cache [dict create -parent $S(-parent) -title $S(-title) \
-font $S(-font) -command $S(-command)]
set r [tclParseConfigSpec [namespace which -variable S] $specs "" $args]
if {![winfo exists $S(-parent)]} {
set code [list TK LOOKUP WINDOW $S(-parent)]
set err "bad window path name \"$S(-parent)\""
array set S $cache
return -code error -errorcode $code $err
}
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) <>
}
return $r
}
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)]
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 -width 18 \
-textvariable [namespace which -variable S](font)
ttk::entry $S(W).estyle -width 10 \
-textvariable [namespace which -variable S](style)
ttk::entry $S(W).esize -textvariable [namespace which -variable S](size) \
-width 3 -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 4 -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]]
# Calculate minimum sizes
ttk::scrollbar $S(W).tmpvs
set scroll_width [winfo reqwidth $S(W).tmpvs]
destroy $S(W).tmpvs
set minsize(gap) 10
set minsize(bbox) [winfo reqwidth $S(W).ok]
set minsize(fonts) \
[expr {[font measure TkDefaultFont "Helvetica"] + $scroll_width}]
set minsize(styles) \
[expr {[font measure TkDefaultFont "Bold Italic"] + $scroll_width}]
set minsize(sizes) \
[expr {[font measure TkDefaultFont "-99"] + $scroll_width}]
set min [expr {$minsize(gap) * 4}]
foreach {what width} [array get minsize] { incr min $width }
wm minsize $S(W) $min 260
bind $S(W) [namespace code [list Done 1]]
bind $S(W) [namespace code [list Done 0]]
bind $S(W)