fontchooser.tcl 16 KB

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