Index: library/fontchooser.tcl ================================================================== --- library/fontchooser.tcl +++ library/fontchooser.tcl @@ -10,47 +10,61 @@ namespace eval ::tk::fontchooser { variable S set S(W) .__tk__fontchooser - set S(fonts) [lsort -dictionary [font families]] + set S(fonts) [lsort -dictionary -unique [font families]] set S(styles) [list \ - [::msgcat::mc "Regular"] \ - [::msgcat::mc "Italic"] \ - [::msgcat::mc "Bold"] \ - [::msgcat::mc "Bold Italic"] \ + [::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(-title) {} set S(-command) "" set S(-font) TkDefaultFont + set S(bad) [list ] +} + +proc ::tk::fontchooser::Canonical {} { + variable S + + foreach style $S(styles) { + lappend S(styles,lcase) [string tolower $style] + } + set S(sizes,lcase) $S(sizes) + set S(sampletext) [::msgcat::mc "AaBbYyZz01"] + + # 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] + } } 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) + Canonical ::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]] + [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 @@ -57,19 +71,29 @@ } } ::tk::fontchooser::Setup proc ::tk::fontchooser::Show {} { - variable S + variable S + + Canonical + if {![winfo exists $S(W)]} { Create wm transient $S(W) [winfo toplevel $S(-parent)] tk::PlaceWindow $S(W) widget $S(-parent) + if {[string trim $S(-title)] eq ""} { + wm title $S(W) [::msgcat::mc "Font"] + } else { + wm title $S(W) $S(-title) + } } - set S(fonts) [lsort -dictionary [font families]] + set S(fonts) [lsort -dictionary -unique [font families]] set S(fonts,lcase) {} - foreach font $S(fonts) { lappend S(fonts,lcase) [string tolower $font]} + foreach font $S(fonts) { + lappend S(fonts,lcase) [string tolower $font] + } wm deiconify $S(W) } proc ::tk::fontchooser::Hide {} { variable S @@ -89,14 +113,14 @@ 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}] + [expr {[info exists S($name)] ? $S($name) : $default}] } lappend result -visible \ - [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}] + [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"]} { @@ -103,29 +127,36 @@ 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" + "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)] + -font $S(-font) -command $S(-command)] set r [tclParseConfigSpec [namespace which -variable S] $specs DONTSETDEFAULTS $args] if {![winfo exists $S(-parent)]} { - set code [list TK LOOKUP WINDOW $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)] && ("-font" in $args)} { - Init $S(-font) - event generate $S(-parent) <> + + if {[winfo exists $S(W)]} { + if {{-font} in $args} { + Init $S(-font) + event generate $S(-parent) <> + } + + if {[string trim $S(-title)] eq {}} { + wm title $S(W) [::msgcat::mc Font] + } else { + wm title $S(W) $S(-title) + } + $S(W).ok configure -state $S(nstate) + $S(W).apply configure -state $S(nstate) } return $r } proc ::tk::fontchooser::Create {} { @@ -138,11 +169,13 @@ } # Now build the dialog if {![winfo exists $S(W)]} { toplevel $S(W) -class TkFontDialog - if {[package provide tcltest] ne {}} {set ::tk_dialog $S(W)} + 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 scaling [tk scaling] @@ -151,60 +184,62 @@ 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:"] -width $sizeWidth ttk::entry $S(W).efont -width 18 \ - -textvariable [namespace which -variable S](font) + -textvariable [namespace which -variable S](font) ttk::entry $S(W).estyle -width 10 \ - -textvariable [namespace which -variable S](style) + -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} + -width 3 -validate key -validatecommand {regexp -- {^-*[0-9]*$} %P} ttk_slistbox $S(W).lfonts -height 7 -exportselection 0 \ - -selectmode browse -activestyle none \ - -listvariable [namespace which -variable S](fonts) + -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) + -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) + -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]] + -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]] + -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]] + -command [namespace code [list Done 1]] ::ttk::button $S(W).cancel -text [::msgcat::mc Cancel] \ - -command [namespace code [list Done 0]] + -command [namespace code [list Done 0]] ::tk::AmpWidget ::ttk::button $S(W).apply -text [::msgcat::mc "&Apply"] \ - -command [namespace code [list 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}] + [expr {[font measure TkDefaultFont "Helvetica"] + $scroll_width}] set minsize(styles) \ - [expr {[font measure TkDefaultFont "Bold Italic"] + $scroll_width}] + [expr {[font measure TkDefaultFont "Bold Italic"] + $scroll_width}] set minsize(sizes) \ - [expr {[font measure TkDefaultFont "-99"] + $scroll_width}] + [expr {[font measure TkDefaultFont "-99"] + $scroll_width}] set min [expr {$minsize(gap) * 4}] - foreach {what width} [array get minsize] {incr min $width} + 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) [namespace code [list Visibility %W 1]] @@ -222,22 +257,20 @@ bind $WE.under <> [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) + -textvariable [namespace which -variable S](sampletext) set S(sample) $WS.sample grid $WS.sample -sticky news -padx 6 -pady 4 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 - if {$S(-command) ne ""} { - grid $S(W).apply -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 @@ -260,18 +293,22 @@ grid columnconfigure $S(W) 0 -weight 1 Init $S(-font) trace add variable [namespace which -variable S](size) \ - write [namespace code [list Tracer]] + write [namespace code [list Tracer]] trace add variable [namespace which -variable S](style) \ - write [namespace code [list Tracer]] + write [namespace code [list Tracer]] trace add variable [namespace which -variable S](font) \ - write [namespace code [list Tracer]] - } else { - Init $S(-font) + write [namespace code [list Tracer]] + trace add variable [namespace which -variable S](strike) \ + write [namespace code [list Tracer]] + trace add variable [namespace which -variable S](under) \ + write [namespace code [list Tracer]] } + + Init $S(-font) return } # ::tk::fontchooser::Done -- @@ -288,13 +325,18 @@ 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]] + trace vdelete S(strike) w [namespace code [list Tracer]] + trace vdelete S(under) w [namespace code [list Tracer]] destroy $S(W) - if {$ok && $S(-command) ne ""} { - uplevel #0 $S(-command) [list $S(result)] + if {$ok} { + if {$S(-command) ne ""} { + uplevel #0 $S(-command) [list $S(result)] + } + event generate $S(-parent) <> } } # ::tk::fontchooser::Apply -- # @@ -320,33 +362,30 @@ # proc ::tk::fontchooser::Init {{defaultFont ""}} { variable S if {$S(first) || $defaultFont ne ""} { + Canonical if {$defaultFont eq ""} { set defaultFont [[entry .___e] cget -font] destroy .___e } array set F [font actual $defaultFont] set S(font) $F(-family) + set S(style) [::msgcat::mc "Regular"] set S(size) $F(-size) set S(strike) $F(-overstrike) set S(under) $F(-underline) - set S(style) [::msgcat::mc "Regular"] if {$F(-weight) eq "bold" && $F(-slant) eq "italic"} { set S(style) [::msgcat::mc "Bold Italic"] } elseif {$F(-weight) eq "bold"} { set S(style) [::msgcat::mc "Bold"] } elseif {$F(-slant) eq "italic"} { set S(style) [::msgcat::mc "Italic"] } - set S(first) 0 } - - Tracer a b c - Update } # ::tk::fontchooser::Click -- # # Handles all button clicks, updating the appropriate widgets @@ -354,19 +393,17 @@ # 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 @@ -374,36 +411,47 @@ # 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 >= 0} { - 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 configure -state $nstate + # We don't need to process strike and under + if {$var2 ni [list strike under]} { + # Make selection in listbox + set value [string tolower $S($var2)] + $S(W).l${var2}s selection clear 0 end + set n [lsearch -exact $S(${var2}s,lcase) $value] + $S(W).l${var2}s selection set $n + if {$n >= 0} { + set S($var2) [lindex $S(${var2}s) $n] + $S(W).e$var2 icursor end + $S(W).e$var2 selection clear + if {[set i [lsearch $S(bad) $var2]] >= 0} { + set S(bad) [lreplace $S(bad) $i $i] + } + } else { + # No match, try prefix + set n [lsearch -glob $S(${var2}s,lcase) "$value*"] + if {$var2 ne "size" || !([regexp -- {^(-[0-9]+|[0-9]+)$} $value] && $value >= -4096 && $value <= 4096)} { + if {[lsearch $S(bad) $var2] < 0} { + lappend S(bad) $var2 + } + } else { + if {[set i [lsearch $S(bad) $var2]] >= 0} { + set S(bad) [lreplace $S(bad) $i $i] + } + } + } + $S(W).l${var2}s see $n + } + if {[llength $S(bad)] == 0} { + set S(nstate) normal + Update + } else { + set S(nstate) disabled + } + $S(W).ok configure -state $S(nstate) + $S(W).apply configure -state $S(nstate) } # ::tk::fontchooser::Update -- # # Shows a sample of the currently selected font @@ -410,17 +458,28 @@ # proc ::tk::fontchooser::Update {} { variable S set S(result) [list $S(font) $S(size)] - if {$S(style) eq [::msgcat::mc "Bold"]} {lappend S(result) bold} - if {$S(style) eq [::msgcat::mc "Italic"]} {lappend S(result) italic} - if {$S(style) eq [::msgcat::mc "Bold Italic"]} {lappend S(result) bold italic} - if {$S(strike)} {lappend S(result) overstrike} - if {$S(under)} {lappend S(result) underline} + if {$S(style) eq [::msgcat::mc "Bold"]} { + lappend S(result) bold + } + if {$S(style) eq [::msgcat::mc "Italic"]} { + lappend S(result) italic + } + if {$S(style) eq [::msgcat::mc "Bold Italic"]} { + lappend S(result) bold italic + } + if {$S(strike)} { + lappend S(result) overstrike + } + if {$S(under)} { + lappend S(result) underline + } $S(sample) configure -font $S(result) + set S(-font) $S(result) } # ::tk::fontchooser::Visibility -- # # Notify the parent when the dialog visibility changes @@ -430,11 +489,11 @@ if {$w eq $S(W)} { event generate $S(-parent) <> } } -# ::tk::fontchooser::ttk_listbox -- +# ::tk::fontchooser::ttk_slistbox -- # # 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} {