[Sciviews-commits] r569 - in pkg/tcltk2: . R inst/tklibs inst/tklibs/choosefont inst/tklibs/choosefont/msgs inst/tklibs/khim inst/tklibs/khim/msgs man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Dec 27 23:41:47 CET 2015
Author: phgrosjean
Date: 2015-12-27 23:41:47 +0100 (Sun, 27 Dec 2015)
New Revision: 569
Added:
pkg/tcltk2/inst/tklibs/choosefont/
pkg/tcltk2/inst/tklibs/choosefont/choosefont.tcl
pkg/tcltk2/inst/tklibs/choosefont/example.tcl
pkg/tcltk2/inst/tklibs/choosefont/msgs/
pkg/tcltk2/inst/tklibs/choosefont/msgs/de.msg
pkg/tcltk2/inst/tklibs/choosefont/msgs/en.msg
pkg/tcltk2/inst/tklibs/choosefont/msgs/fr.msg
pkg/tcltk2/inst/tklibs/choosefont/pkgIndex.tcl
pkg/tcltk2/inst/tklibs/khim/
pkg/tcltk2/inst/tklibs/khim/ChangeLog
pkg/tcltk2/inst/tklibs/khim/khim.man
pkg/tcltk2/inst/tklibs/khim/khim.tcl
pkg/tcltk2/inst/tklibs/khim/msgs/
pkg/tcltk2/inst/tklibs/khim/msgs/ROOT.msg
pkg/tcltk2/inst/tklibs/khim/msgs/cs.msg
pkg/tcltk2/inst/tklibs/khim/msgs/da.msg
pkg/tcltk2/inst/tklibs/khim/msgs/de.msg
pkg/tcltk2/inst/tklibs/khim/msgs/en.msg
pkg/tcltk2/inst/tklibs/khim/msgs/es.msg
pkg/tcltk2/inst/tklibs/khim/msgs/fr.msg
pkg/tcltk2/inst/tklibs/khim/msgs/pl.msg
pkg/tcltk2/inst/tklibs/khim/msgs/ru.msg
pkg/tcltk2/inst/tklibs/khim/msgs/uk.msg
pkg/tcltk2/inst/tklibs/khim/pkgIndex.tcl
Removed:
pkg/tcltk2/inst/tklibs/choosefont0.2/
pkg/tcltk2/inst/tklibs/khim1.0/
Modified:
pkg/tcltk2/DESCRIPTION
pkg/tcltk2/NAMESPACE
pkg/tcltk2/NEWS
pkg/tcltk2/R/tcltk2-Internal.R
pkg/tcltk2/R/tk2commands.R
pkg/tcltk2/R/tk2dialogs.R
pkg/tcltk2/TODO
pkg/tcltk2/man/setLanguage.Rd
pkg/tcltk2/man/tk2dialogs.Rd
Log:
Locale and unicode characters for tcltk2
Modified: pkg/tcltk2/DESCRIPTION
===================================================================
--- pkg/tcltk2/DESCRIPTION 2015-12-27 22:38:15 UTC (rev 568)
+++ pkg/tcltk2/DESCRIPTION 2015-12-27 22:41:47 UTC (rev 569)
@@ -1,7 +1,7 @@
Package: tcltk2
Type: Package
-Version: 1.2-12
-Date: 2015-12-10
+Version: 1.3-0
+Date: 2015-12-27
Title: Tcl/Tk Additions
Author: Philippe Grosjean [aut, cre]
Authors at R: c(person("Philippe", "Grosjean", role = c("aut", "cre"),
@@ -10,7 +10,7 @@
Depends: R (>= 2.8.0), tcltk
Suggests: utils
SystemRequirements: Tcl/Tk (>= 8.5), Tktable (>= 2.9, optional)
-Description: A series of additional Tcl commands and Tk widgets with style and various functions (under Windows: DDE exchange, access to the registry and icon manipulation) to supplement the tcltk package.
+Description: A series of additional Tcl commands and Tk widgets to supplement the tcltk package.
License: LGPL-3 + file LICENSE
-URL: http://www.sciviews.org/SciViews-R
+URL: http://www.sciviews.org/recipes/tcltk/toc/
BugReports: https://r-forge.r-project.org/tracker/?group_id=194
Modified: pkg/tcltk2/NAMESPACE
===================================================================
--- pkg/tcltk2/NAMESPACE 2015-12-27 22:38:15 UTC (rev 568)
+++ pkg/tcltk2/NAMESPACE 2015-12-27 22:41:47 UTC (rev 569)
@@ -62,6 +62,9 @@
tk2theme,
tk2chooseFont,
tk2swaplist,
+ tk2unicode_select,
+ tk2unicode_config,
+ tk2unicode_bind,
tk2edit,
tk2dde,
tk2dde.exec,
@@ -97,6 +100,9 @@
tk2font.setstyle,
getLanguage,
setLanguage,
+ tclmclocale,
+ tclmcset,
+ tclmc,
tk2style,
tk2dataList,
tk2configList,
Modified: pkg/tcltk2/NEWS
===================================================================
--- pkg/tcltk2/NEWS 2015-12-27 22:38:15 UTC (rev 568)
+++ pkg/tcltk2/NEWS 2015-12-27 22:41:47 UTC (rev 569)
@@ -1,5 +1,19 @@
= tcltk2 news
+== Version 1.3-0
+
+* Message translation is completed. setLanguage()/getLanguage() work now in a
+ more robust way. getLanguage() separately reports the language used by R and
+ by Tcl/Tk, and translation catalogs for Tcl and Tk are automatically loaded
+ when the tcltk2 package is loaded. The new functions tclmclocale(), tclmc()
+ and tclmcset() complete the functions available to manage message translation
+ in Tcl from within R.
+
+* A dialog box to enter uncode characters in tk2entry or tk2text widgets and to
+ configure a composer to enter such unicode character on the keyboard are added
+ (functions tk2unicode_xxx()).
+
+
== Version 1.2-12
* A bug led to incorrect tk2list.set(), tk2list.insert() and tk2list.delete()
Modified: pkg/tcltk2/R/tcltk2-Internal.R
===================================================================
--- pkg/tcltk2/R/tcltk2-Internal.R 2015-12-27 22:38:15 UTC (rev 568)
+++ pkg/tcltk2/R/tcltk2-Internal.R 2015-12-27 22:41:47 UTC (rev 569)
@@ -15,11 +15,18 @@
}
res <- addTclPath(libdir) # extend the Tcl/Tk path
- ## Make sure that Tcl/Tk locale is the same one as current R locale
- lang <- getLanguage()
- if (lang != "") { # Set the same language for Tcl/Tk
- res <- tclRequire("msgcat")
- if (inherits(res, "tclObj")) tcl("::msgcat::mclocale", lang)
+ ## Load Tcl and Tk translation catalogs
+ res <- tclRequire("msgcat")
+ if (inherits(res, "tclObj")) {
+ .Tcl("namespace import msgcat::*")
+ .Tcl("mcload [file join $::tcl_library msgs]")
+ .Tcl("mcload [file join $::tk_library msgs]")
+
+ ## Make sure that Tcl/Tk locale is the same one as current R locale
+ lang <- getLanguage()
+ if (lang != "") { # Set the same language for Tcl/Tk
+ setLanguage(lang)
+ }
}
if (is.tk()) {
@@ -42,7 +49,7 @@
tcl("source", file.path(libdir, "tree1.7", "tree.tcl"))
## Do we try to load the tile widgets? (only if Tcl./Tk < 8.5)
- if (as.numeric(.Tcl("set ::tcl_version")) < 8.5) {
+ if (as.numeric(tclvalue("::tcl_version")) < 8.5) {
### tcl("source", file.path(libdir, "fonts.tcl"))
## Define fonts used in Tk (note: must be done AFTER loading tile!)
## Default values for system fonts are calculated by tile...
@@ -100,25 +107,30 @@
} else if ("winnative" %in% themes) { # This must be a pre-XP windows
try(tk2theme("winnative"), silent = TRUE)
} else if (.isUbuntu()) {
- try(tk2theme("radiance"), silent = TRUE)
+ #try(tk2theme("radiance"), silent = TRUE)
+ #We also load clearlooks by default in Ubuntu
+ try(tk2theme("clearlooks"), silent = TRUE)
## Special treatment for Ubuntu: change fonts to Ubuntu and Ubuntu mono
## and use white text on black for tooltips
- tkfont.configure("TkDefaultFont", family = "Ubuntu", size = 11)
- tkfont.configure("TkMenuFont", family = "Ubuntu", size = 11)
- tkfont.configure("TkCaptionFont", family = "Ubuntu", size = 10)
- tkfont.configure("TkSmallCaptionFont", family = "Ubuntu", size = 9)
- tkfont.configure("TkTooltipFont", family = "Ubuntu", size = 9)
- tkfont.configure("TkMenuFont", family = "Ubuntu", size = 11)
- tkfont.configure("TkHeadingFont", family = "Ubuntu", size = 12)
- tkfont.configure("TkIconFont", family = "Ubuntu", size = 11)
- tkfont.configure("TkTextFont", family = "Ubuntu", size = 11)
- tkfont.configure("TkFixedFont", family = "Ubuntu Mono", size = 11)
+
+ ## Again, Tk 8.5/8.6 does a better job by default now than 8.4
+ ## So, we don't need this any more!?
+ #tkfont.configure("TkDefaultFont", family = "Ubuntu", size = 11)
+ #tkfont.configure("TkMenuFont", family = "Ubuntu", size = 11)
+ #tkfont.configure("TkCaptionFont", family = "Ubuntu", size = 10)
+ #tkfont.configure("TkSmallCaptionFont", family = "Ubuntu", size = 9)
+ #tkfont.configure("TkTooltipFont", family = "Ubuntu", size = 9)
+ #tkfont.configure("TkMenuFont", family = "Ubuntu", size = 11)
+ #tkfont.configure("TkHeadingFont", family = "Ubuntu", size = 12)
+ #tkfont.configure("TkIconFont", family = "Ubuntu", size = 11)
+ #tkfont.configure("TkTextFont", family = "Ubuntu", size = 11)
+ #tkfont.configure("TkFixedFont", family = "Ubuntu Mono", size = 11)
res <- tclRequire("tooltip")
if (inherits(res, "tclObj")) {
.Tcl(paste("set ::tooltip::labelOpts [list -highlightthickness 0",
"-relief solid -bd 1 -background black -fg white]"))
}
- } else { # A modern "default" theme that fit not too bad in many situations
+ } else { # A modern "default" theme that fits not too bad in many situations
try(tk2theme("clearlooks"), silent = TRUE)
}
}
@@ -144,7 +156,6 @@
.onUnload <- function (libpath)
{
- # PhG: was .Last.lib()
## Remove all currently scheduled tasks
tclTaskDelete(id = NULL)
}
@@ -158,16 +169,17 @@
if (inherits(theme, 'try-error')) return(FALSE)
## Try changing the tk2theme according to this value
res <- try(tk2theme(theme), silent = TRUE)
- return(!inherits(res, "try-error"))
- } else return(FALSE)
+ !inherits(res, "try-error")
+ } else FALSE
}
.isUbuntu <- function () {
## Note: take care not to call 'cat' on Windows: it is usually *not* there!
if (.Platform$OS.type == "windows" || grepl("^mac", .Platform$pkgType))
return(FALSE) # This is either Windows or Mac OS X!
- grepl("^Ubuntu", suppressWarnings(try(system("cat /etc/issue",
- intern = TRUE, ignore.stderr = TRUE), silent = TRUE))[1])
+ # On Ubuntu, there is an lsb-release file, but read it just to make sure
+ file.exists("/etc/lsb-release") &&
+ any(grepl("[Uu]buntu", readLines("/etc/lsb-release")))
}
.mergeList <- function (l1, l2)
Modified: pkg/tcltk2/R/tk2commands.R
===================================================================
--- pkg/tcltk2/R/tk2commands.R 2015-12-27 22:38:15 UTC (rev 568)
+++ pkg/tcltk2/R/tk2commands.R 2015-12-27 22:41:47 UTC (rev 569)
@@ -435,17 +435,29 @@
return(res)
}
+
+## Management of locales and message translation using msgcat
setLanguage <- function (lang)
{
## Change locale for both R and Tcl/Tk
Sys.setenv(language = lang)
- try(Sys.setlocale("LC_MESSAGES", lang), silent = TRUE) # Fails on Windows!
+ Sys.setenv(LANG = lang)
+ #try(Sys.setlocale("LC_MESSAGES", lang), silent = TRUE) # Fails on Windows!
res <- tclRequire("msgcat")
if (inherits(res, "tclObj")) {
- tcl("::msgcat::mclocale", lang)
- return(TRUE)
+ .Tcl("namespace import msgcat::*")
+ # If the tcl.language attribute is defined, use it
+ tcllang <- attr(lang, "tcl.language")
+ if (!is.null(tcllang) && tcllang[1] != "") {
+ lang <- tcllang[1] # Use only first item
+ } else {
+ # Tcl does not accept locales like en_US.UF-8: must be en_us only
+ lang <- tolower(sub("^([^.]+)\\..*$", "\\1", lang))
+ }
+ tclmclocale(lang)
+ TRUE
} else {
- return(FALSE)
+ FALSE
}
}
@@ -456,10 +468,42 @@
if (lang == "") lang <- Sys.getlocale("LC_MESSAGES")
## This is a bad hack that probably does not work all the time, but at least,
## it works under Windows for getting "fr" for French language
- if (lang == "") lang <- tolower(substr(Sys.getlocale("LC_TIME"), 1, 2))
- return(lang)
+ if (lang == "") lang <- tolower(substr(Sys.getlocale("LC_COLLATE"), 1, 2))
+
+ ## Try to get language information from Tcl
+ tcllang <- try(as.character(tcl("mcpreferences")), silent = TRUE)
+ attr(lang, "tcl.language") <- tcllang
+
+ lang
}
+tclmclocale <- function (lang) {
+ if (missing(lang)) {
+ as.character(tcl("mclocale"))
+ } else {
+ # Make sure lang is made compatible to Tcl
+ lang <- tolower(sub("^([^.]+)\\..*$", "\\1", lang))
+ as.character(tcl("mclocale", lang))
+ }
+}
+
+tclmcset <- function(lang, msg, translation)
+ invisible(tclvalue(tcl("mcset", lang, msg, translation)))
+
+tclmc <- function (fmt, ..., domain = NULL) {
+ if (is.null(domain) || domain == "") {
+ # Simpler form
+ tclvalue(tcl("mc", fmt, ...))
+ } else {
+ # Need to evaluate in 'domain' Tcl namespace
+ transl <- .Tcl(paste0("namespace eval ", domain, " {set ::Rtransl [mc {",
+ fmt, "}]}"))
+ sprintf(tclvalue(transl), ...)
+ }
+}
+
+
+## Check if Tk or Tttk aze available
is.tk <- function ()
return(tclvalue(.Tcl("catch { package present Tk }")) == "0")
Modified: pkg/tcltk2/R/tk2dialogs.R
===================================================================
--- pkg/tcltk2/R/tk2dialogs.R 2015-12-27 22:38:15 UTC (rev 568)
+++ pkg/tcltk2/R/tk2dialogs.R 2015-12-27 22:41:47 UTC (rev 569)
@@ -12,5 +12,81 @@
{
if (!is.tk()) stop("Package Tk is required but not loaded")
tclRequire("choosefont")
+ # Make sure message translations are correctly loaded
+ try(tcl("mcload", system.file("tklibs", "choosefile", "msgs",
+ package = "tcltk2")), silent = TRUE)
tcl("choosefont::choosefont", ...)
}
+
+## Unicode character input
+.tk2unicode_file <- function (app = getOption("tk2app", "R"))
+ file.path("~", paste0(".khimrc.", as.character(app)[1]))
+
+.tk2unicode_load <- function ()
+{
+ ## Try to get current configuration
+ cfg <- try(tcl("::khim::getConfig"), silent = TRUE)
+ if (inherits(cfg, "try-error")) {
+ ## Try loading the khim package
+ res <- tclRequire("khim")
+ if (!inherits(res, "tclObj")) return()
+ ## If a config file exists, load it now
+ cfgfile <- .tk2unicode_file()
+ if (file.exists(cfgfile))
+ tcl("source", cfgfile)
+ ## finally get the updated config
+ cfg <- tcl("::khim::getConfig")
+ }
+ # Make sure message translations are correctly loaded
+ try(tcl("mcload", system.file("tklibs", "khim", "msgs",
+ package = "tcltk2")), silent = TRUE)
+ tclvalue(cfg)
+}
+
+tk2unicode_config <- function (parent)
+{
+ if (!inherits(parent, "tkwin"))
+ stop("'parent' must be a 'tkwin' object")
+
+ ## Make sure khim is loaded and get its current config
+ cfg <- .tk2unicode_load()
+
+ ## Display the configuration dialog box
+ .Tcl(paste0("::khim::getOptions ", parent$ID, ".khim"))
+
+ ## Get the new config and compare it with the old one
+ cfg2 <- tclvalue(tcl("::khim::getConfig"))
+ if (cfg2 != cfg) {
+ ## Ask to save the new config
+ msg <- tclmc("Do you want to save this configuration on disk?",
+ domain = "khim")
+ res <- tkmessageBox(
+ message = msg, icon = "question", type = "yesno")
+ if (tclvalue(res) == "yes") {
+ cfgfile <- .tk2unicode_file()
+ cat(cfg2, file = cfgfile)
+ }
+ }
+}
+
+tk2unicode_select <- function (widget)
+{
+ .tk2unicode_load()
+ tcl("::khim::FocusAndInsertSymbol", widget$ID)
+}
+
+tk2unicode_bind <- function (widget)
+{
+ if (!inherits(widget, c("tk2text", "tk2entry")))
+ stop("You can bind the unicode composer to tk2text() or tk2entry() widgets only")
+ ## Make sure evertything is loaded and configured correctly
+ .tk2unicode_load()
+ ## Create the binding
+ if (inherits(widget, "tk2text")) {
+ tkbindtags(widget, paste0(widget$ID , " KHIM Text ",
+ widget$env$parent$ID, " all"))
+ } else { # This must be a tk2entry widget
+ tkbindtags(widget, paste0(widget$ID , " KHIM Entry ",
+ widget$env$parent$ID, " all"))
+ }
+}
Modified: pkg/tcltk2/TODO
===================================================================
--- pkg/tcltk2/TODO 2015-12-27 22:38:15 UTC (rev 568)
+++ pkg/tcltk2/TODO 2015-12-27 22:41:47 UTC (rev 569)
@@ -3,15 +3,11 @@
* Despite I changed ::msgcat::mclocale to de, tk2chooseFont() is still in
English (but it works for fr... why?)
-* tile.use(FALSE) after loading tile does not work with tk2chooseFont()
-
* Rework tk2edit() [takes numeric only and return characters for the moment!
rework also the button bar]
-* Add twapi, toolbar, tkdnd, datefield and swaplist
+* Add toolbar, datefield, etc.
-* Rework the code to detect and work with ActiveState install under Linux
-
* For the tips: select background color and font from style (same for bwidgets)
* The package vignette
@@ -33,14 +29,9 @@
tclvars
unknown
A function to display the Tcl/Tk help and additional package help from R
- Use of the msgcat Tcl package
- easier definition and retrieval of bindings (+ keysyms) and events
- bitmap (2 colors) and image (+ IMG package? PPM/PGM and GIF by default)
- cursors
- experiment with focus -force! + lower/raise
- font manipulation functions + homogeneity of fonts between R and Tk
- styles must be handled with option! + tk_setPalette?
- GUI designer for fixed place of widgets
- tk/tkvars to retrieve various tk information
+ Easier definition and retrieval of bindings (+ keysyms) and events
+ Bitmap (2 colors) and image (+ IMG package? PPM/PGM and GIF by default)
+ Cursors
+ Experiment with focus -force! + lower/raise
* Make a demo section
Added: pkg/tcltk2/inst/tklibs/choosefont/choosefont.tcl
===================================================================
--- pkg/tcltk2/inst/tklibs/choosefont/choosefont.tcl (rev 0)
+++ pkg/tcltk2/inst/tklibs/choosefont/choosefont.tcl 2015-12-27 22:41:47 UTC (rev 569)
@@ -0,0 +1,609 @@
+###############################
+#
+# a pure Tcl/Tk font chooser
+#
+# by ulis, 2002
+#
+# NOL (No Obligation Licence)
+#
+#
+# modifs by Martin Lemburg, 2002
+# Basic Tile'ification and msgcat support
+# by schlenk, 2005
+#
+# Adaptation to R and further enhancements
+# by Philippe Grosjean, 2007, GNU GPL 2 or above license
+###############################
+
+package require Tcl 8.4
+package require Tk 8.4
+package require msgcat
+#package require tile 0.7.2 ;# The dialog displays tile widgets if package loaded
+
+namespace eval ::choosefont {
+ namespace import ::msgcat::mc
+ namespace export choosefont
+
+ variable w .choosefont
+ variable font
+ variable listvar
+ variable family
+ variable size
+ variable bold
+ variable italic
+ variable underline
+ variable overstrike
+ variable ok
+ variable lock 1
+
+ variable defaultopts
+
+ variable usetile
+ variable locale
+ set usetile 0
+ set locale [::msgcat::mclocale]
+
+ variable mnemonics
+ variable mnemopaths
+ set mnemonics {}
+ set mnemopaths {}
+
+ # Get internationalization string
+ ::msgcat::mcload [file join [file dirname [info script]] msgs]
+
+ # This is for correct handling of amperstand as mnemonic indicators (Alt-Key)
+ proc mca {widget text} {
+ variable mnemonics
+ variable mnemopaths
+
+ foreach {newtext under} [::tk::UnderlineAmpersand [mc $text]] {
+ $widget configure -text $newtext -underline $under
+ }
+ # Add this info to the list of mnemonics
+ if {$under > -1} {
+ lappend mnemonics [string tolower [string index $newtext $under]]
+ lappend mnemopaths $widget
+ }
+ }
+
+ # This font is inspired from tile
+ # Make sure that TkDefaultFont is defined
+ if {[lsearch [font names] TkDefaultFont] == -1} {
+ catch {font create TkDefaultFont}
+ switch -- [tk windowingsystem] {
+ win32 {
+ if {$tcl_platform(osVersion) >= 5.0} {
+ font configure TkDefaultFont -family "Tahoma" -size -11
+ } else {
+ font configure TkDefaultFont -family "MS Sans Serif" -size -11
+ }
+ }
+ classic -
+ aqua {
+ font configure TkDefaultFont -family "Lucida Grande" -size 13
+ }
+ x11 {
+ if {![catch {tk::pkgconfig get fontsystem} fs] && $fs eq "xft"} {
+ font configure TkDefaultFont -family "sans-serif" -size -12
+ } else {
+ font configure TkDefaultFont -family "Helvetica" -size -12
+ }
+ }
+ }
+ }
+
+ # ================
+ # choose a font
+ # ================
+ # args:
+ # -font an initial (and optional) font
+ # -title an optional title
+ # -fonttype 'all' (by default), 'fixed' or 'prop'
+ # -style do we activate additional 'style' options?
+ # >= 1 => 'bold'
+ # >= 2 => 'italic'
+ # >= 3 => 'underline'
+ # >= 4 => 'overstrike'
+ # -sizetype 'all' (by default), 'point', 'pixel'
+ # returns:
+ # "" if the user aborted
+ # or the description of the selected font
+ # usage:
+ # namespace import ::choosefont::choosefont
+ # choosefont "Courier 10 italic" "new font"
+
+ proc choosefont {args} {
+ if {[llength $args] & 1} {
+ return -code error "invalid number of arguments given to choosefont (uneven number) : $args"
+ }
+
+ global tcl_platform
+ global tile_use
+
+ # ------------------
+ # get choosefont env
+ # ------------------
+ variable ::choosefont::w
+ variable ::choosefont::font
+ variable ::choosefont::listvarall
+ variable ::choosefont::listvarfixed
+ variable ::choosefont::listvarprop
+ variable ::choosefont::listvar
+ variable ::choosefont::family
+ variable ::choosefont::size
+ variable ::choosefont::bold
+ variable ::choosefont::italic
+ variable ::choosefont::underline
+ variable ::choosefont::overstrike
+ variable ::choosefont::ok
+ variable ::choosefont::usetile
+ variable ::choosefont::locale
+ variable ::choosefont::mnemonics
+ variable ::choosefont::mnempaths
+ variable ::choosefont::lock
+
+ # ------------------
+ # handling of optional arguments
+ # ------------------
+ variable ::choosefont::defaultopts
+ variable opts
+ # Initialize de fault fonts (done only once)
+ if {![info exists defaultopts]} {
+ set defaultopts {-font "" -title "" -fonttype all -style 4 -sizetype all}
+ }
+ # Create an array (easier to work with)
+ array set opts $defaultopts
+ # Override options provided as arguments
+ array set opts $args
+
+ # ------------------
+ # current font
+ # ------------------
+ if {$opts(-font) != ""} { set font $opts(-font) }
+ if {![info exists font]} {
+ # We try to get the default text or fixed font, depending on fonttype
+ if {$opts(-fonttype) == "fixed"} {
+ catch { set font [font actual TkFixedFont] }
+ } else { ;# 'all' or 'prop'
+ catch { set font [font actual TkTextFont] }
+ }
+ }
+ # Make sure that the default one is correct regarding 'fixed' or 'prop'
+ # Otherwise, select default fonts instead
+ if {$opts(-fonttype) == "fixed" & [font metrics $font -fixed] == 0 } {
+ catch { set font "courier" }
+ }
+ if {$opts(-fonttype) == "prop" & [font metrics $font -fixed] == 1 } {
+ catch { set font "helvetica" }
+ }
+
+ # ------------------
+ # dialog
+ # ------------------
+ set notile [catch { package present tile }]
+ catch {if {[winfo exists $tile_use] && $tile_use == 0} {set notile 1}}
+ # If it is not the first time the dialog is displayed
+ # and tile presence, or locale has changed
+ # then, we destroy the dialog box and rebuild it
+ if {[winfo exists $w]} {
+ if {$notile != $usetile || [::msgcat::mclocale] != $locale} {
+ destroy $w
+ set mnemonics {}
+ set mnemopaths {}
+ }
+ }
+ set usetile $notile
+ set locale [::msgcat::mclocale]
+
+ if {[winfo exists $w]} {
+ # show the dialog
+ wm deiconify $w
+
+ # Switch to the corresponding list of fonts ('all', 'prop' or 'fixed')
+ switch -exact -- [string tolower $opts(-fonttype)] {
+ fixed { set listvar $listvarfixed }
+ prop { set listvar $listvarprop }
+ default { set listvar $listvarall }
+ }
+
+ # Possibly reconfigure the size selector
+ if {$notile} {
+ switch $opts(-sizetype) {
+ point {
+ set minsize 1; set maxsize 100
+ }
+ pixel {
+ set minsize -100; set maxsize -1
+ }
+ default {
+ set minsize -100; set maxsize 100
+ }
+ }
+ $w.fa.f.esize configure -from $minsize -to $maxsize
+ } else {
+ switch $opts(-sizetype) {
+ point {
+ $w.fa.f.esize configure -values [list 7 8 9 10 11 12 13 14 15 \
+ 20 25 30 40]
+ }
+ pixel {
+ $w.fa.f.esize configure -values [list -20 -15 -14 -13 -12 -11 \
+ -10 -9 -8]
+ }
+ default {
+ $w.fa.f.esize configure -values [list -20 -15 -14 -13 -12 -11 \
+ -10 -9 -8 7 8 9 10 11 12 13 14 15 20 25 30 40]
+ }
+ }
+ }
+ } else { ;# Create the dialog box
+ if {[info exists listvarall] == 0} {
+ set listvarall [lsort -dictionary [font families]]
+ #PhG: allow to filter out fixed and/or proportional fonts
+ set listvarfixed {}
+ set listvarprop {}
+ foreach family $listvarall {
+ if {[font metrics "{$family}" -fixed] == 1 } {
+ lappend listvarfixed $family
+ } else {
+ lappend listvarprop $family
+ }
+ }
+ }
+ switch -exact -- [string tolower $opts(-fonttype)] {
+ fixed { set listvar $listvarfixed }
+ prop { set listvar $listvarprop }
+ default { set listvar $listvarall }
+ }
+
+ # create the dialog
+ toplevel $w -class Dialog
+ wm resizable $w 0 0
+ wm title $w [mc "Choose a font"]
+ wm iconname $w Dialog
+ wm protocol $w WM_DELETE_WINDOW { }
+
+ # PhG: under Windows, make it topmost, so that it is always visible
+ if { [regexp topmost [wm attributes $w]] == 1 } {
+ wm attributes $w -topmost 1
+ }
+ # Dialog boxes should be transient with respect to their parent,
+ # so that they will always stay on top of their parent window. However,
+ # some window managers will create the window as withdrawn if the parent
+ # window is withdrawn or iconified. Combined with the grab we put on the
+ # window, this can hang the entire application. Therefore we only make
+ # the dialog transient if the parent is viewable.
+ if {[winfo viewable [winfo toplevel [winfo parent $w]]] } {
+ wm transient $w [winfo toplevel [winfo parent $w]]
+ }
+
+ if {[string equal $tcl_platform(platform) "macintosh"]
+ || [string equal [tk windowingsystem] "aqua"]} {
+ ::tk::unsupported::MacWindowStyle style $w dBoxProc
+ }
+
+ # create widgets
+ if {$notile} {
+ frame $w.f -bd 1 -relief sunken
+ } else {
+ ttk::labelframe $w.f
+ }
+ # We never use tile for these ones
+ label $w.f.h -height 4
+ label $w.f.l -textvariable ::choosefont::family
+
+ if {$notile} {
+ frame $w.fl
+ label $w.fl.la -font TkDefaultFont
+ listbox $w.fl.lb -listvar ::choosefont::listvar -width 30 \
+ -font TkDefaultFont -yscrollcommand [list $w.fl.sb set] \
+ -selectmode single -exportselection 0
+ scrollbar $w.fl.sb -command [list $w.fl.lb yview]
+ } else {
+ ttk::frame $w.fl
+ ttk::label $w.fl.la
+ listbox $w.fl.lb -listvar ::choosefont::listvar -width 30 -bd 0 \
+ -font TkDefaultFont -yscrollcommand [list $w.fl.sb set] \
+ -selectmode single -exportselection 0
+ ttk::scrollbar $w.fl.sb -orient vertical -command [list $w.fl.lb yview]
+ }
+ mca $w.fl.la &Family:
+
+ if {$notile} {
+ frame $w.fa -bd 2 -relief groove
+ frame $w.fa.f
+ label $w.fa.f.lsize -font TkDefaultFont
+ switch $opts(-sizetype) {
+ point {
+ set minsize 1; set maxsize 100
+ }
+ pixel {
+ set minsize -100; set maxsize -1
+ }
+ default {
+ set minsize -100; set maxsize 100
+ }
+ }
+ spinbox $w.fa.f.esize -textvariable ::choosefont::size -width 3 \
+ -validate focusout -vcmd {string is integer -strict %P} \
+ -from $minsize -to $maxsize -font TkDefaultFont
+ checkbutton $w.fa.f.bold -variable ::choosefont::bold \
+ -font TkDefaultFont
+ checkbutton $w.fa.f.italic -variable ::choosefont::italic \
+ -font TkDefaultFont
+ checkbutton $w.fa.f.under -variable ::choosefont::underline \
+ -font TkDefaultFont
+ checkbutton $w.fa.f.over -variable ::choosefont::overstrike \
+ -font TkDefaultFont
+ } else {
+ ttk::labelframe $w.fa
+ ttk::frame $w.fa.f
+ ttk::label $w.fa.f.lsize
+ ttk::combobox $w.fa.f.esize -textvariable ::choosefont::size \
+ -width 3 -exportselection 0
+ switch $opts(-sizetype) {
+ point {
+ $w.fa.f.esize configure -values [list 7 8 9 10 11 12 13 14 15 \
+ 20 25 30 40]
+ }
+ pixel {
+ $w.fa.f.esize configure -values [list -20 -15 -14 -13 -12 -11 \
+ -10 -9 -8]
+ }
+ default {
+ $w.fa.f.esize configure -values [list -20 -15 -14 -13 -12 -11 \
+ -10 -9 -8 7 8 9 10 11 12 13 14 15 20 25 30 40]
+ }
+ }
+ ttk::checkbutton $w.fa.f.bold -variable ::choosefont::bold
+ ttk::checkbutton $w.fa.f.italic -variable ::choosefont::italic
+ ttk::checkbutton $w.fa.f.under -variable ::choosefont::underline
+ ttk::checkbutton $w.fa.f.over -variable ::choosefont::overstrike
+ }
+ mca $w.fa.f.lsize &Size:
+ mca $w.fa.f.bold &Bold
+ mca $w.fa.f.italic &Italic
+ mca $w.fa.f.under &Underline
+ mca $w.fa.f.over &Overstrike
+
+ if {$notile} {
+ frame $w.fb
+ button $w.fb.ok -text [mc OK] -width 10 \
+ -command { set ::choosefont::ok 1 } -font TkDefaultFont
+ button $w.fb.cancel -text [mc Cancel] -width 10 \
+ -command { set ::choosefont::ok 0 } -font TkDefaultFont
+ } else {
+ ttk::frame $w.fb
+ ttk::button $w.fb.ok -text [mc OK] -width 10 \
+ -command { set ::choosefont::ok 1 }
+ ttk::button $w.fb.cancel -text [mc Cancel] -width 10 \
+ -command { set ::choosefont::ok 0 }
+ }
+ wm protocol $w WM_DELETE_WINDOW { $::choosefont::w.fb.cancel invoke }
+
+ # bind events
+ bind $w.fl.lb <ButtonRelease-1> {
+ set ::choosefont::family [%W get [%W cursel]]
+ focus %W
+ }
+
+ # listbox handling
+ bind $w <Home> { ::choosefont::selectfont %W First }
+ bind $w <End> { ::choosefont::selectfont %W Last }
+ bind $w <Control-Home> { ::choosefont::selectfont %W First }
+ bind $w <Control-End> { ::choosefont::selectfont %W Last }
+ bind $w <Key-Next> { ::choosefont::selectfont %W PgDown }
+ bind $w <Key-Prior> { ::choosefont::selectfont %W PgUp }
+ bind $w <KeyPress> { ::choosefont::selectfont %W %K }
+
+ # buttons handling
+ bind $w <Escape> [list $w.fb.cancel invoke]
+ bind $w <Return> [list $w.fb.ok invoke]
+
+ # Alt-key navigation
+ if {[llength $mnemonics] > 0} {
+ bind $w <Alt-Key> {
+ set w [winfo toplevel %W]
+ set key [string tolower %K]
+ set pos [lsearch $::choosefont::mnemonics $key]
+ if {$pos > -1} {
+ set target [lindex $::choosefont::mnemopaths $pos]
+ event generate $target <<AltUnderlined>>
+ }
+ }
+ }
+ bind $w.fl.la <<AltUnderlined>> [list focus $w.fl.lb]
+ bind $w.fa.f.lsize <<AltUnderlined>> { focus $w.fa.f.esize }
+ bind $w.fa.f.bold <<AltUnderlined>> {
+ $w.fa.f.bold invoke; focus $w.fa.f.bold }
+ bind $w.fa.f.italic <<AltUnderlined>> {
+ $w.fa.f.italic invoke; focus $w.fa.f.italic }
+ bind $w.fa.f.under <<AltUnderlined>> {
+ $w.fa.f.under invoke; focus $w.fa.f.under }
+ bind $w.fa.f.over <<AltUnderlined>> {
+ $w.fa.f.over invoke; focus $w.fa.f.over }
+
+ set lock 1
+
+ trace variable ::choosefont::family w ::choosefont::createfont
+ trace variable ::choosefont::size w ::choosefont::createfont
+ trace variable ::choosefont::bold w ::choosefont::createfont
+ trace variable ::choosefont::italic w ::choosefont::createfont
+ trace variable ::choosefont::underline w ::choosefont::createfont
+ trace variable ::choosefont::overstrike w ::choosefont::createfont
+
+ # place widgets
+ grid $w.f -row 0 -column 0 -columnspan 2 -sticky nsew -pady {2 5}
+ grid $w.fl -row 1 -column 0 -padx 5 -pady 5
+ grid $w.fa -row 1 -column 1 -sticky nsew -padx 5 -pady 5
+ grid $w.fb -row 2 -column 0 -columnspan 2 -sticky ew -pady 7
+ grid $w.f.h -row 0 -column 0
+ grid $w.f.l -row 0 -column 1 -sticky nsew -pady 3
+ grid $w.fl.la -row 0 -column 0 -sticky nw -pady 3
+ grid $w.fl.lb -row 1 -column 0
+ grid $w.fl.sb -row 1 -column 1 -sticky ns
+ grid $w.fa.f -padx 5 -pady 5
+ grid $w.fa.f.lsize -row 0 -column 0 -padx 5 -pady 10 -sticky w
+ grid $w.fa.f.esize -row 0 -column 1 -sticky w
+ grid $w.fa.f.bold -row 1 -column 0 -columnspan 2 -sticky w
+ grid $w.fa.f.italic -row 2 -column 0 -columnspan 2 -sticky w
+ grid $w.fa.f.under -row 3 -column 0 -columnspan 2 -sticky w
+ grid $w.fa.f.over -row 4 -column 0 -columnspan 2 -sticky w
+ grid $w.fb.ok $w.fb.cancel -padx 20
+ # Center the Window on screen the first time it is used
+ ::tk::PlaceWindow $w
+ }
+
+ # Reconfigure the dialog box with current font
+ set family [font actual $font -family]
+ set size [font actual $font -size]
+ set bold [expr {[font actual $font -weight] == "bold"}]
+ if {$opts(-style) > 0} { # Allow bold
+ $w.fa.f.bold configure -state normal
+ } else {
+ $w.fa.f.bold configure -state disabled
+ }
+ set italic [expr {[font actual $font -slant] == "italic"}]
+ if {$opts(-style) > 1} { # Allow italic
+ $w.fa.f.italic configure -state normal
+ } else {
+ $w.fa.f.italic configure -state disabled
+ }
+ set underline [font actual $font -underline]
+ if {$opts(-style) > 2} { # Allow underline
+ $w.fa.f.under configure -state normal
+ } else {
+ $w.fa.f.under configure -state disabled
+ }
+ set overstrike [font actual $font -overstrike]
+ if {$opts(-style) > 3} { # Allow overstrike
+ $w.fa.f.over configure -state normal
+ } else {
+ $w.fa.f.over configure -state disabled
+ }
+
+ set lock 0
+ ::choosefont::createfont
+
+ # ------------------
+ # end of dialog
+ # ------------------
+
+ if {$opts(-title) != ""} {
+ wm title $w $opts(-title)
+ } else {
+ wm title $w [mc "Choose a font"]
+ }
+ set newIndex [lsearch -exact $listvar $family]
+ # PhG: clear the selection list first!
+ $w.fl.lb selection clear 0 end
+ # PhG: this is needed by R, otherwise, there is a bug with the list
+ update
+ $w.fl.lb selection set $newIndex
+ $w.fl.lb activate $newIndex
+ $w.fl.lb see $newIndex
+ # PhG: focus on the list
+ focus $w.fl.lb
+
+ # Grab the focus, wait for user action
+ ::tk::SetFocusGrab $w $w.fl.lb
+ vwait ::choosefont::ok
+ # Restore the focus and hide the font chooser dialog box
+ ::tk::RestoreFocusGrab $w $w.fl.lb withdraw
+
+ if {$ok} {
+ return [::choosefont::createfont]
+ } else {
+ return ""
+ }
+ }
+
+ # ================
+ # ancillary procs
+ # ================
+ proc selectfont {w mode} {
+ if {[winfo class $w] != "Listbox"} { return }
+
+ set oldIndex [$w curselection]
+
+ if {[string length $mode] > 1} {
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/sciviews -r 569
More information about the Sciviews-commits
mailing list