figenc

[RADIOACTIVE] rsa and symmetric key encryption scripts and executables
git clone git://git.figbert.com/figenc.git
Log | Files | Refs | README

fontchooser.tcl (15840B)


      1 # fontchooser.tcl -
      2 #
      3 #	A themeable Tk font selection dialog. See TIP #324.
      4 #
      5 # Copyright (C) 2008 Keith Vetter
      6 # Copyright (C) 2008 Pat Thoyts <patthoyts@users.sourceforge.net>
      7 #
      8 # See the file "license.terms" for information on usage and redistribution
      9 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
     10 
     11 namespace eval ::tk::fontchooser {
     12     variable S
     13 
     14     set S(W) .__tk__fontchooser
     15     set S(fonts) [lsort -dictionary [font families]]
     16     set S(styles) [list \
     17                        [::msgcat::mc "Regular"] \
     18                        [::msgcat::mc "Italic"] \
     19                        [::msgcat::mc "Bold"] \
     20                        [::msgcat::mc "Bold Italic"] \
     21                       ]
     22 
     23     set S(sizes) {8 9 10 11 12 14 16 18 20 22 24 26 28 36 48 72}
     24     set S(strike) 0
     25     set S(under) 0
     26     set S(first) 1
     27     set S(sampletext) [::msgcat::mc "AaBbYyZz01"]
     28     set S(-parent) .
     29     set S(-title) [::msgcat::mc "Font"]
     30     set S(-command) ""
     31     set S(-font) TkDefaultFont
     32 }
     33 
     34 proc ::tk::fontchooser::Setup {} {
     35     variable S
     36 
     37     # Canonical versions of font families, styles, etc. for easier searching
     38     set S(fonts,lcase) {}
     39     foreach font $S(fonts) { lappend S(fonts,lcase) [string tolower $font]}
     40     set S(styles,lcase) {}
     41     foreach style $S(styles) { lappend S(styles,lcase) [string tolower $style]}
     42     set S(sizes,lcase) $S(sizes)
     43 
     44     ::ttk::style layout FontchooserFrame {
     45         Entry.field -sticky news -border true -children {
     46             FontchooserFrame.padding -sticky news
     47         }
     48     }
     49     bind [winfo class .] <<ThemeChanged>> \
     50         [list +ttk::style layout FontchooserFrame \
     51              [ttk::style layout FontchooserFrame]]
     52 
     53     namespace ensemble create -map {
     54         show ::tk::fontchooser::Show
     55         hide ::tk::fontchooser::Hide
     56         configure ::tk::fontchooser::Configure
     57     }
     58 }
     59 ::tk::fontchooser::Setup
     60 
     61 proc ::tk::fontchooser::Show {} {
     62     variable S
     63     if {![winfo exists $S(W)]} {
     64         Create
     65         wm transient $S(W) [winfo toplevel $S(-parent)]
     66         tk::PlaceWindow $S(W) widget $S(-parent)
     67     }
     68     set S(fonts) [lsort -dictionary [font families]]
     69     set S(fonts,lcase) {}
     70     foreach font $S(fonts) { lappend S(fonts,lcase) [string tolower $font]}
     71     wm deiconify $S(W)
     72 }
     73 
     74 proc ::tk::fontchooser::Hide {} {
     75     variable S
     76     wm withdraw $S(W)
     77 }
     78 
     79 proc ::tk::fontchooser::Configure {args} {
     80     variable S
     81 
     82     set specs {
     83         {-parent  "" "" . }
     84         {-title   "" "" ""}
     85         {-font    "" "" ""}
     86         {-command "" "" ""}
     87     }
     88 
     89     if {[llength $args] == 0} {
     90         set result {}
     91         foreach spec $specs {
     92             foreach {name xx yy default} $spec break
     93             lappend result $name \
     94                 [expr {[info exists S($name)] ? $S($name) : $default}]
     95         }
     96         lappend result -visible \
     97             [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}]
     98         return $result
     99     }
    100     if {[llength $args] == 1} {
    101         set option [lindex $args 0]
    102         if {[string equal $option "-visible"]} {
    103             return [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}]
    104         } elseif {[info exists S($option)]} {
    105             return $S($option)
    106         }
    107         return -code error -errorcode [list TK LOOKUP OPTION $option] \
    108 	    "bad option \"$option\": must be\
    109             -command, -font, -parent, -title or -visible"
    110     }
    111 
    112     set cache [dict create -parent $S(-parent) -title $S(-title) \
    113                    -font $S(-font) -command $S(-command)]
    114     set r [tclParseConfigSpec [namespace which -variable S] $specs "" $args]
    115     if {![winfo exists $S(-parent)]} {
    116 	set code [list TK LOOKUP WINDOW $S(-parent)]
    117         set err "bad window path name \"$S(-parent)\""
    118         array set S $cache
    119         return -code error -errorcode $code $err
    120     }
    121     if {[string trim $S(-title)] eq ""} {
    122         set S(-title) [::msgcat::mc "Font"]
    123     }
    124     if {[winfo exists $S(W)] && [lsearch $args -font] != -1} {
    125 	Init $S(-font)
    126 	event generate $S(-parent) <<TkFontchooserFontChanged>>
    127     }
    128     return $r
    129 }
    130 
    131 proc ::tk::fontchooser::Create {} {
    132     variable S
    133     set windowName __tk__fontchooser
    134     if {$S(-parent) eq "."} {
    135         set S(W) .$windowName
    136     } else {
    137         set S(W) $S(-parent).$windowName
    138     }
    139 
    140     # Now build the dialog
    141     if {![winfo exists $S(W)]} {
    142         toplevel $S(W) -class TkFontDialog
    143         if {[package provide tcltest] ne {}} {set ::tk_dialog $S(W)}
    144         wm withdraw $S(W)
    145         wm title $S(W) $S(-title)
    146         wm transient $S(W) [winfo toplevel $S(-parent)]
    147 
    148         set outer [::ttk::frame $S(W).outer -padding {10 10}]
    149         ::tk::AmpWidget ::ttk::label $S(W).font -text [::msgcat::mc "&Font:"]
    150         ::tk::AmpWidget ::ttk::label $S(W).style -text [::msgcat::mc "Font st&yle:"]
    151         ::tk::AmpWidget ::ttk::label $S(W).size -text [::msgcat::mc "&Size:"]
    152         ttk::entry $S(W).efont -width 18 \
    153             -textvariable [namespace which -variable S](font)
    154         ttk::entry $S(W).estyle -width 10 \
    155             -textvariable [namespace which -variable S](style)
    156         ttk::entry $S(W).esize -textvariable [namespace which -variable S](size) \
    157             -width 3 -validate key -validatecommand {string is double %P}
    158 
    159         ttk_slistbox $S(W).lfonts -height 7 -exportselection 0 \
    160             -selectmode browse -activestyle none \
    161             -listvariable [namespace which -variable S](fonts)
    162         ttk_slistbox $S(W).lstyles -width 5 -height 7 -exportselection 0 \
    163             -selectmode browse -activestyle none \
    164             -listvariable [namespace which -variable S](styles)
    165         ttk_slistbox $S(W).lsizes -width 4 -height 7 -exportselection 0 \
    166             -selectmode browse -activestyle none \
    167             -listvariable [namespace which -variable S](sizes)
    168 
    169         set WE $S(W).effects
    170         ::ttk::labelframe $WE -text [::msgcat::mc "Effects"]
    171         ::tk::AmpWidget ::ttk::checkbutton $WE.strike \
    172             -variable [namespace which -variable S](strike) \
    173             -text [::msgcat::mc "Stri&keout"] \
    174             -command [namespace code [list Click strike]]
    175         ::tk::AmpWidget ::ttk::checkbutton $WE.under \
    176             -variable [namespace which -variable S](under) \
    177             -text [::msgcat::mc "&Underline"] \
    178             -command [namespace code [list Click under]]
    179 
    180         set bbox [::ttk::frame $S(W).bbox]
    181         ::ttk::button $S(W).ok -text [::msgcat::mc OK] -default active\
    182             -command [namespace code [list Done 1]]
    183         ::ttk::button $S(W).cancel -text [::msgcat::mc Cancel] \
    184             -command [namespace code [list Done 0]]
    185         ::tk::AmpWidget ::ttk::button $S(W).apply -text [::msgcat::mc "&Apply"] \
    186             -command [namespace code [list Apply]]
    187         wm protocol $S(W) WM_DELETE_WINDOW [namespace code [list Done 0]]
    188 
    189         # Calculate minimum sizes
    190         ttk::scrollbar $S(W).tmpvs
    191         set scroll_width [winfo reqwidth $S(W).tmpvs]
    192         destroy $S(W).tmpvs
    193         set minsize(gap) 10
    194         set minsize(bbox) [winfo reqwidth $S(W).ok]
    195         set minsize(fonts) \
    196             [expr {[font measure TkDefaultFont "Helvetica"] + $scroll_width}]
    197         set minsize(styles) \
    198             [expr {[font measure TkDefaultFont "Bold Italic"] + $scroll_width}]
    199         set minsize(sizes) \
    200             [expr {[font measure TkDefaultFont "-99"] + $scroll_width}]
    201         set min [expr {$minsize(gap) * 4}]
    202         foreach {what width} [array get minsize] { incr min $width }
    203         wm minsize $S(W) $min 260
    204 
    205         bind $S(W) <Return> [namespace code [list Done 1]]
    206         bind $S(W) <Escape> [namespace code [list Done 0]]
    207         bind $S(W) <Map> [namespace code [list Visibility %W 1]]
    208         bind $S(W) <Unmap> [namespace code [list Visibility %W 0]]
    209         bind $S(W) <Destroy> [namespace code [list Visibility %W 0]]
    210         bind $S(W).lfonts.list <<ListboxSelect>> [namespace code [list Click font]]
    211         bind $S(W).lstyles.list <<ListboxSelect>> [namespace code [list Click style]]
    212         bind $S(W).lsizes.list <<ListboxSelect>> [namespace code [list Click size]]
    213         bind $S(W) <Alt-Key> [list ::tk::AltKeyInDialog $S(W) %A]
    214         bind $S(W).font <<AltUnderlined>> [list ::focus $S(W).efont]
    215         bind $S(W).style <<AltUnderlined>> [list ::focus $S(W).estyle]
    216         bind $S(W).size <<AltUnderlined>> [list ::focus $S(W).esize]
    217         bind $S(W).apply <<AltUnderlined>> [namespace code [list Apply]]
    218         bind $WE.strike <<AltUnderlined>> [list $WE.strike invoke]
    219         bind $WE.under <<AltUnderlined>> [list $WE.under invoke]
    220 
    221         set WS $S(W).sample
    222         ::ttk::labelframe $WS -text [::msgcat::mc "Sample"]
    223         ::ttk::label $WS.sample -relief sunken -anchor center \
    224             -textvariable [namespace which -variable S](sampletext)
    225         set S(sample) $WS.sample
    226         grid $WS.sample -sticky news -padx 6 -pady 4
    227         grid rowconfigure $WS 0 -weight 1
    228         grid columnconfigure $WS 0 -weight 1
    229         grid propagate $WS 0
    230 
    231         grid $S(W).ok     -in $bbox -sticky new -pady {0 2}
    232         grid $S(W).cancel -in $bbox -sticky new -pady 2
    233         if {$S(-command) ne ""} {
    234             grid $S(W).apply -in $bbox -sticky new -pady 2
    235         }
    236         grid columnconfigure $bbox 0 -weight 1
    237 
    238         grid $WE.strike -sticky w -padx 10
    239         grid $WE.under -sticky w -padx 10 -pady {0 30}
    240         grid columnconfigure $WE 1 -weight 1
    241 
    242         grid $S(W).font   x $S(W).style   x $S(W).size   x       -in $outer -sticky w
    243         grid $S(W).efont  x $S(W).estyle  x $S(W).esize  x $bbox -in $outer -sticky ew
    244         grid $S(W).lfonts x $S(W).lstyles x $S(W).lsizes x ^     -in $outer -sticky news
    245         grid $WE          x $WS           - -            x ^     -in $outer -sticky news -pady {15 30}
    246         grid configure $bbox -sticky n
    247         grid columnconfigure $outer {1 3 5} -minsize $minsize(gap)
    248         grid columnconfigure $outer {0 2 4} -weight 1
    249         grid columnconfigure $outer 0 -minsize $minsize(fonts)
    250         grid columnconfigure $outer 2 -minsize $minsize(styles)
    251         grid columnconfigure $outer 4 -minsize $minsize(sizes)
    252         grid columnconfigure $outer 6 -minsize $minsize(bbox)
    253 
    254         grid $outer -sticky news
    255         grid rowconfigure $S(W) 0 -weight 1
    256         grid columnconfigure $S(W) 0 -weight 1
    257 
    258         Init $S(-font)
    259 
    260         trace add variable [namespace which -variable S](size) \
    261             write [namespace code [list Tracer]]
    262         trace add variable [namespace which -variable S](style) \
    263             write [namespace code [list Tracer]]
    264         trace add variable [namespace which -variable S](font) \
    265             write [namespace code [list Tracer]]
    266     } else {
    267         Init $S(-font)
    268     }
    269 
    270     return
    271 }
    272 
    273 # ::tk::fontchooser::Done --
    274 #
    275 #       Handles teardown of the dialog, calling -command if needed
    276 #
    277 # Arguments:
    278 #       ok              true if user pressed OK
    279 #
    280 proc ::tk::::fontchooser::Done {ok} {
    281     variable S
    282 
    283     if {! $ok} {
    284         set S(result) ""
    285     }
    286     trace vdelete S(size) w [namespace code [list Tracer]]
    287     trace vdelete S(style) w [namespace code [list Tracer]]
    288     trace vdelete S(font) w [namespace code [list Tracer]]
    289     destroy $S(W)
    290     if {$ok && $S(-command) ne ""} {
    291         uplevel #0 $S(-command) [list $S(result)]
    292     }
    293 }
    294 
    295 # ::tk::fontchooser::Apply --
    296 #
    297 #	Call the -command procedure appending the current font
    298 #	Errors are reported via the background error mechanism
    299 #
    300 proc ::tk::fontchooser::Apply {} {
    301     variable S
    302     if {$S(-command) ne ""} {
    303         if {[catch {uplevel #0 $S(-command) [list $S(result)]} err]} {
    304             ::bgerror $err
    305         }
    306     }
    307     event generate $S(-parent) <<TkFontchooserFontChanged>>
    308 }
    309 
    310 # ::tk::fontchooser::Init --
    311 #
    312 #       Initializes dialog to a default font
    313 #
    314 # Arguments:
    315 #       defaultFont     font to use as the default
    316 #
    317 proc ::tk::fontchooser::Init {{defaultFont ""}} {
    318     variable S
    319 
    320     if {$S(first) || $defaultFont ne ""} {
    321         if {$defaultFont eq ""} {
    322             set defaultFont [[entry .___e] cget -font]
    323             destroy .___e
    324         }
    325         array set F [font actual $defaultFont]
    326         set S(font) $F(-family)
    327         set S(size) $F(-size)
    328         set S(strike) $F(-overstrike)
    329         set S(under) $F(-underline)
    330         set S(style) "Regular"
    331         if {$F(-weight) eq "bold" && $F(-slant) eq "italic"} {
    332             set S(style) "Bold Italic"
    333         } elseif {$F(-weight) eq "bold"} {
    334             set S(style) "Bold"
    335         } elseif {$F(-slant) eq "italic"} {
    336             set S(style) "Italic"
    337         }
    338 
    339         set S(first) 0
    340     }
    341 
    342     Tracer a b c
    343     Update
    344 }
    345 
    346 # ::tk::fontchooser::Click --
    347 #
    348 #       Handles all button clicks, updating the appropriate widgets
    349 #
    350 # Arguments:
    351 #       who             which widget got pressed
    352 #
    353 proc ::tk::fontchooser::Click {who} {
    354     variable S
    355 
    356     if {$who eq "font"} {
    357         set S(font) [$S(W).lfonts get [$S(W).lfonts curselection]]
    358     } elseif {$who eq "style"} {
    359         set S(style) [$S(W).lstyles get [$S(W).lstyles curselection]]
    360     } elseif {$who eq "size"} {
    361         set S(size) [$S(W).lsizes get [$S(W).lsizes curselection]]
    362     }
    363     Update
    364 }
    365 
    366 # ::tk::fontchooser::Tracer --
    367 #
    368 #       Handles traces on key variables, updating the appropriate widgets
    369 #
    370 # Arguments:
    371 #       standard trace arguments (not used)
    372 #
    373 proc ::tk::fontchooser::Tracer {var1 var2 op} {
    374     variable S
    375 
    376     set bad 0
    377     set nstate normal
    378     # Make selection in each listbox
    379     foreach var {font style size} {
    380         set value [string tolower $S($var)]
    381         $S(W).l${var}s selection clear 0 end
    382         set n [lsearch -exact $S(${var}s,lcase) $value]
    383         $S(W).l${var}s selection set $n
    384         if {$n != -1} {
    385             set S($var) [lindex $S(${var}s) $n]
    386             $S(W).e$var icursor end
    387             $S(W).e$var selection clear
    388         } else {                                ;# No match, try prefix
    389             # Size is weird: valid numbers are legal but don't display
    390             # unless in the font size list
    391             set n [lsearch -glob $S(${var}s,lcase) "$value*"]
    392             set bad 1
    393             if {$var ne "size" || ! [string is double -strict $value]} {
    394                 set nstate disabled
    395             }
    396         }
    397         $S(W).l${var}s see $n
    398     }
    399     if {!$bad} { Update }
    400     $S(W).ok configure -state $nstate
    401 }
    402 
    403 # ::tk::fontchooser::Update --
    404 #
    405 #       Shows a sample of the currently selected font
    406 #
    407 proc ::tk::fontchooser::Update {} {
    408     variable S
    409 
    410     set S(result) [list $S(font) $S(size)]
    411     if {$S(style) eq "Bold"} { lappend S(result) bold }
    412     if {$S(style) eq "Italic"} { lappend S(result) italic }
    413     if {$S(style) eq "Bold Italic"} { lappend S(result) bold italic}
    414     if {$S(strike)} { lappend S(result) overstrike}
    415     if {$S(under)} { lappend S(result) underline}
    416 
    417     $S(sample) configure -font $S(result)
    418 }
    419 
    420 # ::tk::fontchooser::Visibility --
    421 #
    422 #	Notify the parent when the dialog visibility changes
    423 #
    424 proc ::tk::fontchooser::Visibility {w visible} {
    425     variable S
    426     if {$w eq $S(W)} {
    427         event generate $S(-parent) <<TkFontchooserVisibility>>
    428     }
    429 }
    430 
    431 # ::tk::fontchooser::ttk_listbox --
    432 #
    433 #	Create a properly themed scrolled listbox.
    434 #	This is exactly right on XP but may need adjusting on other platforms.
    435 #
    436 proc ::tk::fontchooser::ttk_slistbox {w args} {
    437     set f [ttk::frame $w -style FontchooserFrame -padding 2]
    438     if {[catch {
    439         listbox $f.list -relief flat -highlightthickness 0 -borderwidth 0 {*}$args
    440         ttk::scrollbar $f.vs -command [list $f.list yview]
    441         $f.list configure -yscrollcommand [list $f.vs set]
    442         grid $f.list $f.vs -sticky news
    443         grid rowconfigure $f 0 -weight 1
    444         grid columnconfigure $f 0 -weight 1
    445         interp hide {} $w
    446         interp alias {} $w {} $f.list
    447     } err opt]} {
    448         destroy $f
    449         return -options $opt $err
    450     }
    451     return $w
    452 }