fontchooser.tcl 17 KB

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