texlive[54823] Master: GUI font scaling; change language and font
commits+siepo at tug.org
commits+siepo at tug.org
Tue Apr 21 13:51:02 CEST 2020
Revision: 54823
http://tug.org/svn/texlive?view=revision&revision=54823
Author: siepo
Date: 2020-04-21 13:51:02 +0200 (Tue, 21 Apr 2020)
Log Message:
-----------
GUI font scaling; change language and font size on the fly
Modified Paths:
--------------
trunk/Master/texmf-dist/scripts/tlshell/tlshell.tcl
trunk/Master/tlpkg/installer/install-tl-gui.tcl
trunk/Master/tlpkg/tltcl/tltcl.tcl
Modified: trunk/Master/texmf-dist/scripts/tlshell/tlshell.tcl
===================================================================
--- trunk/Master/texmf-dist/scripts/tlshell/tlshell.tcl 2020-04-20 23:55:21 UTC (rev 54822)
+++ trunk/Master/texmf-dist/scripts/tlshell/tlshell.tcl 2020-04-21 11:51:02 UTC (rev 54823)
@@ -26,7 +26,79 @@
set ::instroot [exec kpsewhich -var-value=TEXMFROOT]
-# declarations and utilities shared with install-tl-gui.tcl
+# try to read a configuration variable (gui-lang, tkfontscale)
+# from tlmgr config ($TEXMF[SYS]CONFIG/tlmgr/config
+# failure results in an empty string.
+# this proc will be invoked by tltcl if tlshell is the invoker of tltcl
+proc get_config_var {k} {
+ set v ""
+ set r [join [list {^\s*} $k {\s*=\s*(\S.*)$}] ""]
+ foreach tmf {"TEXMFCONFIG" "TEXMFSYSCONFIG"} {
+ if [catch {exec kpsewhich -var-value $tmf} d] {
+ break; # apparently there is not yet a TL installation
+ }
+
+ if [catch {open [file join $d "tlmgr" "config"] r} fid] continue
+ while 1 {
+ if [chan eof $fid] {
+ break
+ }
+ if [catch {chan gets $fid} l] break
+ # we can assume that $k contains no special characters
+ if [regexp $r $l m v] {
+ set v [regsub {\s*$} $v ""]
+ break
+ } else {
+ # regexp will have unset v
+ set v ""
+ }
+ }
+ chan close $fid
+ if {$v ne ""} break
+ }
+ return $v
+}
+
+proc save_config_var {k v} {
+ if [catch {exec kpsewhich -var-value "TEXMFCONFIG"} d] {return 0}
+ set d [file join $d "tlmgr"]
+ if [catch {file mkdir $d}] {return 0} ; # mkdir on existing dir is ok
+ set fn [file join $d "config"]
+ set oldlines [list]
+ set r [join [list {^\s*} $k {\s*=\s*(\S.*)$}] ""]
+ # read current config file
+ if [file exists $fn] {
+ if [catch {open $fn r} fid] {return 0}
+ set cnt 0
+ while 1 {
+ if [catch {chan gets $fid} l] break
+ if [chan eof $fid] break
+ incr cnt
+ if {! [regexp $r $l]} {
+ lappend oldlines $l
+ }
+ if {$cnt>40} break
+ }
+ catch {chan close $fid}
+ }
+ lappend oldlines "$k = $v"
+ if [catch {open $fn w} fid] {return 0}
+ foreach l $oldlines {
+ if [catch {puts $fid $l}] {
+ catch {chan close $fid}
+ return 0
+ }
+ }
+ catch {chan close $fid}
+ return 1
+}
+
+# tltcl: declarations and utilities shared with install-tl-gui.tcl
+# tltcl likes to know who was the invoker
+set ::invoker [file tail [info script]]
+if [string match -nocase ".tcl" [string range $::invoker end-3 end]] {
+ set ::invoker [string range $::invoker 0 end-4]
+}
source [file join $::instroot "tlpkg" "tltcl" "tltcl.tcl"]
# now is a good time to ask tlmgr for the _TL_ name of our platform
@@ -54,9 +126,6 @@
# menus: disable tearoff feature
option add *Menu.tearOff 0
-# for busy/idle indicators
-set ::busy [__ "Idle"]
-
proc search_nocase {needle haystack} {
if {$needle eq ""} {return -1}
if {$haystack eq ""} {return -1}
@@ -205,8 +274,45 @@
}
} ; # any_message
-### enabling and disabling user interaction
+##### tl global data ##################################################
+set ::last_cmd ""
+
+set ::progname [info script]
+regexp {^.*[\\/]([^\\/\.]*)(?:\....)?$} $progname dummy ::progname
+set ::procid [pid]
+
+# package repositories
+array unset ::repos
+
+# mirrors: dict of dicts of lists of urls per country per continent
+# moved to tltcl.tcl
+#set ::mirrors [dict create]
+
+# dict of (local and global) package dicts
+set ::pkgs [dict create]
+
+# platforms
+set ::platforms [dict create]
+
+set ::have_remote 0 ; # remote packages info not yet loaded
+set ::need_update_tlmgr 0
+set ::n_updates 0
+set ::tlshell_updatable 0
+
+## package data to be displayed ##
+
+# sorted display data for packages; package data stored as lists
+set ::filtered [dict create]
+
+# selecting packages for display: status and detail
+set ::stat_opt "inst"
+set ::dtl_opt "all"
+# searching packages for display; also search short descriptions?
+set ::search_desc 0
+
+### enabling and disabling user interaction based on global data
+
proc selective_dis_enable {} {
# disable actions which make no sense at the time
@@ -275,43 +381,6 @@
}
} ; # total_dis_enable
-##### tl global data ##################################################
-
-set ::last_cmd ""
-
-set ::progname [info script]
-regexp {^.*[\\/]([^\\/\.]*)(?:\....)?$} $progname dummy ::progname
-set ::procid [pid]
-
-# package repositories
-array unset ::repos
-
-# mirrors: dict of dicts of lists of urls per country per continent
-# moved to tltcl.tcl
-#set ::mirrors [dict create]
-
-# dict of (local and global) package dicts
-set ::pkgs [dict create]
-
-# platforms
-set ::platforms [dict create]
-
-set ::have_remote 0 ; # remote packages info not yet loaded
-set ::need_update_tlmgr 0
-set ::n_updates 0
-set ::tlshell_updatable 0
-
-## package data to be displayed ##
-
-# sorted display data for packages; package data stored as lists
-set ::filtered [dict create]
-
-# selecting packages for display: status and detail
-set ::stat_opt "inst"
-set ::dtl_opt "all"
-# searching packages for display; also search short descriptions?
-set ::search_desc 0
-
##### handling tlmgr via pipe and stderr tempfile #####################
set ::prmpt "tlmgr>"
@@ -539,8 +608,8 @@
# with a virtual repository, which is the combined set of repositories,
# with pinning applied if there is more than one repository.
# But get_packages_info_remote must invoke
-# show_repositories to display updated verification info.
-# show_repositories is also invoked by initialize.
+# show_repos to display updated verification info.
+# show_repos is also invoked by initialize.
# get_packages_info_local is invoked only once, at initialization. After
# installations and removals, the collected information is updated by
@@ -572,6 +641,18 @@
return [expr {$lr > 0 && $rr > 0 && $rr > $lr}]
}
+proc display_updated_globals {} {
+ if {$::have_remote && $::need_update_tlmgr} {
+ .topfll.luptodate configure -text [__ "Needs updating"]
+ } elseif $::have_remote {
+ .topfll.luptodate configure -text [__ "Up to date"]
+ } else {
+ .topfll.luptodate configure -text [__ "Unknown"]
+ }
+ # ... and status of update buttons
+ selective_dis_enable
+}
+
proc update_globals {} {
if {! $::have_remote} return
set ::n_updates 0
@@ -582,15 +663,7 @@
set ::tlshell_updatable [is_updatable tlshell]
# also update displayed status info
- if {$::have_remote && $::need_update_tlmgr} {
- .topfll.luptodate configure -text [__ "Needs updating"]
- } elseif $::have_remote {
- .topfll.luptodate configure -text [__ "Up to date"]
- } else {
- .topfll.luptodate configure -text [__ "Unknown"]
- }
- # ... and status of update buttons
- selective_dis_enable
+ display_updated_globals
}
# The package display treeview widget in the main window has columns
@@ -682,9 +755,13 @@
dict lappend ::filtered $nm $v
dict lappend ::filtered $nm [dict get $pk shortdesc]
}
- display_packages_info
} ; # collect_filtered
+proc collect_and_display_filtered {} {
+ collect_filtered
+ display_packages_info
+}
+
proc get_platforms {} {
# guarantee fresh start
foreach k $::platforms {dict unset ::platforms $k}
@@ -1061,6 +1138,9 @@
}; # set_repos_in_tlmgr
proc show_repos {} {
+ # this proc lists the configured repository/ies
+ # in the upper left portion of the main window.
+ # it makes one call to the back end, but no need to go online.
set w .toprepo
foreach ch [winfo children $w] {destroy $ch}
set nms [array names ::repos]
@@ -1171,7 +1251,7 @@
# reload remote package information
set ::have_remote 0
get_packages_info_remote
- collect_filtered
+ collect_and_display_filtered
}
proc select_mir {m} {
@@ -1329,7 +1409,7 @@
run_cmds $cmds 1
vwait ::done_waiting
update_local_revnumbers
- collect_filtered
+ collect_and_display_filtered
} ; # platforms_do
@@ -1411,7 +1491,7 @@
# We won't wait for the log dialog to close, but we will
# update the packages display in the main window.
update_local_revnumbers
- collect_filtered
+ collect_and_display_filtered
} ; # finish_restore
proc restore_all {} {
@@ -1602,7 +1682,7 @@
update_local_revnumbers
.topfr.linfra configure -text \
"tlmgr: r[dict get $::pkgs texlive.infra localrev]"
- collect_filtered
+ collect_and_display_filtered
} ; # update_tlmgr
proc update_all {} {
@@ -1628,7 +1708,7 @@
vwait ::done_waiting
update_local_revnumbers
}
- collect_filtered
+ collect_and_display_filtered
} ; # update_all
### doing something with some packages
@@ -1688,7 +1768,7 @@
}
update_local_revnumbers
if {$sel_opt eq "marked"} {mark_all 0}
- collect_filtered
+ collect_and_display_filtered
} ; # install_pkgs
proc update_pkgs {sel_opt {pk ""}} {
@@ -1761,7 +1841,7 @@
}
update_local_revnumbers
if {$sel_opt eq "marked"} {mark_all 0}
- collect_filtered
+ collect_and_display_filtered
} ; # update_pkgs
proc remove_pkgs {sel_opt {pk ""}} {
@@ -1822,7 +1902,7 @@
}
update_local_revnumbers
if {$sel_opt eq "marked"} {mark_all 0}
- collect_filtered
+ collect_and_display_filtered
} ; # remove_pkgs
# restoring packages is a rather different story, controlled by the
@@ -1908,55 +1988,34 @@
run_cmd "paper paper $p" 1
}
-proc set_language_no_restart {l} {
- set ok 1
- if [catch {exec kpsewhich -var-value "TEXMFCONFIG"} d] {set ok 0}
- if $ok {
- set d [file join $d "tlmgr"]
- if [catch {file mkdir $d}] {set ok 0}
- }
- set fn [file join $d "config"]
- set oldlines [list]
- if {$ok && ! [catch {open $fn r} fid]} {
- set cnt 0
- while 1 {
- if [catch {chan gets $fid} ll] break
- if [chan eof $fid] break
- incr cnt
- if {! [regexp {^\s*gui-lang} $ll]} {
- lappend oldlines $ll
- }
- if {$cnt>20} break
- }
- catch {chan close $fid}
- }
- lappend oldlines "gui-lang = $l"
- if {$ok && ! [catch {open $fn w} fid]} {
- foreach ll $oldlines {
- if [catch {puts $fid $ll}] {
- set ok 0
- break
- }
- }
- catch {chan close $fid}
- }
- return $ok
-} ; # set_language_no_restart
+#### gui options ####
proc set_language {l} {
- if [set_language_no_restart $l] {
- restart_self
- } else {
- tk_messageBox -message [__ "Cannot set default GUI language"] -icon error
+ set ::lang $l
+ load_translations
+ rebuild_interface
+ if {! [save_config_var "gui-lang" $::lang]} {
+ tk_messageBox -message [__"Cannot save language setting"]
}
}
+proc set_fontscale {s} {
+ set ::tkfontscale $s
+ redo_fonts
+ rebuild_interface
+ if {[dict get $::pkgs texlive.infra localrev] >= 54766} {
+ if {! [save_config_var "tkfontscale" $::tkfontscale]} {
+ tk_messageBox -message [__"Cannot save font scale setting"]
+ }
+ }
+}
+
##### running external commands #####
# For capturing an external command, we need a separate output channel,
# but we reuse ::out_log.
# stderr is bundled with stdout so ::err_log should stay empty.
-proc read_capt {} {
+proc read_capture {} {
set l "" ; # will contain the line to be read
if {([catch {chan gets $::capt l} len] || [chan eof $::capt])} {
catch {chan close $::capt}
@@ -1966,7 +2025,7 @@
lappend ::out_log $l
log_widget_add $l
}
-}; # read_capt
+}; # read_capture
proc run_external {cmd mess} {
set ::out_log {}
@@ -1982,10 +2041,16 @@
tk_messageBox -message "Failure to launch $cmd"
}
chan configure $::capt -buffering line -blocking 0
- chan event $::capt readable read_capt
+ chan event $::capt readable read_capture
log_widget_init
}
+proc about_cmd {} {
+ set msg "\u00a9 2017-2020 Siep Kroonenberg\n\n"
+ append msg [__ "GUI interface for TeX Live Manager\nImplemented in Tcl/Tk"]
+ tk_messageBox -message $msg
+}
+
proc show_help {} {
set ::env(NOPERLDOC) 1
long_message [exec tlmgr --help] ok
@@ -2012,7 +2077,7 @@
proc try_loading_remote {} {
if {[possible_repository $::repos(main)]} {
get_packages_info_remote
- collect_filtered
+ collect_and_display_filtered
} else {
set mes [__ "%s is not a local or remote repository.
Please configure a valid repository" $::repos(main)]
@@ -2027,9 +2092,6 @@
wm title . "TeX Live Shell"
- # width of '0', as a rough estimate of average character width
- set ::cw [font measure TkTextFont "0"]
-
## menu ##
# dummy empty menu to replace the real menu .mn in disabled states.
@@ -2049,10 +2111,10 @@
.mn configure -borderwidth 1
.mn configure -background $::default_bg
- # plain_unix: avoid a RenderBadPicture error on quitting.
- # 'send' changes the shutdown sequence,
- # which avoids triggering the bug.
- # 'tk appname <something>' restores 'send' and avoids the bug
+ # plain_unix: avoid a possible RenderBadPicture error on quitting
+ # when there is a menu.
+ # 'send' bypasses the bug by changing the shutdown sequence.
+ # 'tk appname <something>' restores 'send'.
bind . <Destroy> {
catch {tk appname appname}
}
@@ -2099,18 +2161,35 @@
if {[llength $::langs] > 1} {
incr inx
- .mn.opt add cascade -label [__ "GUI language (restarts tlshell)"] \
+ .mn.opt add cascade -label [__ "GUI language"] \
-menu .mn.opt.lang
menu .mn.opt.lang
foreach l [lsort $::langs] {
if {$l eq $::lang} {
- .mn.opt.lang add command -label "$l *"
+ set mlabel "$l *"
} else {
- .mn.opt.lang add command -label "$l" -command "set_language $l"
+ set mlabel $l
}
+ .mn.opt.lang add command -label $mlabel \
+ -command "set_language $l"
}
}
+ incr inx
+ .mn.opt add cascade -label [__ "GUI font scaling"] \
+ -menu .mn.opt.fscale
+ menu .mn.opt.fscale
+ foreach s {0.5 0.7 1 1.25 1.5 2 3 4 6 8} {
+ if {$s eq $::tkfontscale} {
+ set mlabel "$s *"
+ } else {
+ set mlabel $s
+ }
+ .mn.opt.fscale add command -label $mlabel \
+ -command "set_fontscale $s"
+ }
+
+
if {$::tcl_platform(platform) ne "windows"} {
incr inx
set ::inx_platforms $inx
@@ -2119,10 +2198,7 @@
.mn add cascade -label [__ "Help"] -menu .mn.help -underline 0
menu .mn.help
- .mn.help add command -label [__ "About"] -command {
- tk_messageBox -message [string cat "\u00a9 2017-2019 Siep Kroonenberg
-
-" [__ "GUI interface for TeX Live Manager\nImplemented in Tcl/Tk"]]}
+ .mn.help add command -label [__ "About"] -command about_cmd
.mn.help add command -label [__ "tlmgr help"] -command show_help
## menu end
@@ -2205,16 +2281,16 @@
# filter on status: inst, all, upd
ttk::label .pkfilter.lstat -font TkHeadingFont -text [__ "Status"]
ttk::radiobutton .pkfilter.inst -text [__ "Installed"] -value inst \
- -variable ::stat_opt -command collect_filtered
+ -variable ::stat_opt -command collect_and_display_filtered
ttk::radiobutton .pkfilter.alls -text [__ "All"] -value all \
-variable ::stat_opt -command {
if {! $::have_remote} get_packages_info_remote
- collect_filtered
+ collect_and_display_filtered
}
ttk::radiobutton .pkfilter.upd -text [__ "Updatable"] -value upd \
-variable ::stat_opt -command {
if {! $::have_remote} get_packages_info_remote
- collect_filtered
+ collect_and_display_filtered
}
grid .pkfilter.lstat -column 0 -row 0 -sticky w -padx {3 50}
pgrid .pkfilter.inst -column 0 -row 1 -sticky w
@@ -2224,11 +2300,11 @@
# filter on detail level: all, coll, schm
ttk::label .pkfilter.ldtl -font TkHeadingFont -text [__ "Detail >> Global"]
ttk::radiobutton .pkfilter.alld -text [__ All] -value all \
- -variable ::dtl_opt -command collect_filtered
+ -variable ::dtl_opt -command collect_and_display_filtered
ttk::radiobutton .pkfilter.coll -text [__ "Collections and schemes"] \
- -value coll -variable ::dtl_opt -command collect_filtered
+ -value coll -variable ::dtl_opt -command collect_and_display_filtered
ttk::radiobutton .pkfilter.schm -text [__ "Only schemes"] -value schm \
- -variable ::dtl_opt -command collect_filtered
+ -variable ::dtl_opt -command collect_and_display_filtered
pgrid .pkfilter.ldtl -column 1 -row 0 -sticky w
pgrid .pkfilter.alld -column 1 -row 1 -sticky w
pgrid .pkfilter.coll -column 1 -row 2 -sticky w
@@ -2320,6 +2396,28 @@
wm state . normal
}
+# to be invoked at initialization and after a font scaling change
+proc rebuild_interface {} {
+ foreach c [winfo children .] {catch {destroy $c}}
+
+ # for busy/idle indicators
+ set ::busy [__ "Idle"]
+ populate_main
+ # and now redisplay all data
+ if {$::tcl_platform(platform) eq "windows"} {
+ .topfr.ladmin configure -text \
+ [expr {$::multiuser ? [__ "Multi-user"] : [__ "Single-user"]}]
+ }
+ # svns for tlmgr and tlshell
+ .topfr.linfra configure -text \
+ "tlmgr: r[dict get $::pkgs texlive.infra localrev]"
+ .topfr.lshell configure -text \
+ "tlshell: r[dict get $::pkgs tlshell localrev]"
+ show_repos
+ display_packages_info
+ display_updated_globals
+}
+
##### initialize ######################################################
proc initialize {} {
@@ -2367,15 +2465,8 @@
set ::flid [open $fname w]
}
- # languages
- set ::langs [list "en"]
- foreach l [glob -nocomplain -directory \
- [file join $::instroot "tlpkg" "translations"] *.po] {
- lappend ::langs [string range [file tail $l] 0 end-3]
- }
-
# store language in tlmgr configuration
- set_language_no_restart $::lang
+ save_config_var "gui-lang" $::lang
# in case we are going to do something with json:
# add json subdirectory to auto_path, but at low priority
@@ -2401,19 +2492,11 @@
foreach l $::out_log {
if [regexp {^\s*multiuser\s+([01])\s*$} $l d ::multiuser] break
}
- .topfr.ladmin configure -text \
- [expr {$::multiuser ? [__ "Multi-user"] : [__ "Single-user"]}]
}
get_packages_info_local
+ collect_filtered
get_repos_from_tlmgr
- show_repos
- # svns for tlmgr and tlshell
- .topfr.linfra configure -text \
- "tlmgr: r[dict get $::pkgs texlive.infra localrev]"
- .topfr.lshell configure -text \
- "tlshell: r[dict get $::pkgs tlshell localrev]"
- collect_filtered ; # invokes display_packages_info
- selective_dis_enable
+ rebuild_interface
}; # initialize
initialize
Modified: trunk/Master/tlpkg/installer/install-tl-gui.tcl
===================================================================
--- trunk/Master/tlpkg/installer/install-tl-gui.tcl 2020-04-20 23:55:21 UTC (rev 54822)
+++ trunk/Master/tlpkg/installer/install-tl-gui.tcl 2020-04-21 11:51:02 UTC (rev 54823)
@@ -45,7 +45,12 @@
set ::instroot [file dirname [file dirname [file dirname $::instroot]]]
# declarations, initializations and procs shared with tlshell.tcl
+set ::invoker [file tail [info script]]
+if [string match -nocase ".tcl" [string range $::invoker end-3 end]] {
+ set ::invoker [string range $::invoker 0 end-4]
+}
source [file join $::instroot "tlpkg" "tltcl" "tltcl.tcl"]
+unset ::invoker
### initialize some globals ###
@@ -408,7 +413,7 @@
# some text
ppack [ttk::label .text -text [__ "TeX Live Installer"] \
- -font bigfont] -in .bg
+ -font hfont] -in .bg
if {! $::select_repo} {
ppack [ttk::label .loading -text [__ "Trying to load %s.
@@ -934,13 +939,6 @@
ppack .tlbin.cancel -in .tlbin.buts -side right
bind .tlbin <Escape> {.tlbin.cancel invoke}
- #set max_width 0
- #foreach b [array names ::bin_descs] {
- # set bl [font measure TkTextFont [__ $::bin_descs($b)]]
- # if {$bl > $max_width} {set max_width $bl}
- #}
- #incr max_width 10
-
# treeview for binaries, with checkbox column and vertical scrollbar
pack [ttk::frame .tlbin.binsf] -in .tlbin.bg -expand 1 -fill both
@@ -1005,12 +1003,6 @@
bind .tlschm <Escape> {.tlschm.cancel invoke}
# schemes list
- #set max_width 0
- #foreach s $::schemes_order {
- # set sl [font measure TkTextFont [__ $::scheme_descs($s)]]
- # if {$sl > $max_width} {set max_width $sl}
- #}
- #incr max_width 10
ttk::treeview .tlschm.lst -columns {desc} -show {} -selectmode browse \
-height [llength $::schemes_order]
.tlschm.lst column "desc" -stretch 1; # -minwidth $max_width
@@ -1315,6 +1307,23 @@
#############################################################
+proc set_language {l} {
+ set ::lang $l
+ load_translations
+ run_menu
+}
+
+proc set_fontscale {s} {
+ set ::tkfontscale $s
+ redo_fonts
+ run_menu
+}
+
+# menus: disable tearoff feature
+option add *Menu.tearOff 0
+
+#############################################################
+
# the main menu interface will at certain events send the current values of
# the ::vars array to install-tl[-tcl], which will send back an updated version
# of this array.
@@ -1324,6 +1333,17 @@
# for 3-way options, create an extra level of children
# instead of wizard install, supppress some options
+## default_bg color, only used for menus under ::plain_unix
+if [catch {ttk::style lookup TFrame -background} ::default_bg] {
+ set ::default_bg white
+}
+
+proc abort_menu {} {
+ set ::out_log {}
+ set ::menu_ans "no_inst"
+ # i.e. anything but advanced, alltrees or startinst
+}
+
proc run_menu {} {
if [info exists ::env(dbgui)] {
#puts "\ndbgui: run_menu: advanced is now $::advanced"
@@ -1334,7 +1354,56 @@
catch {destroy $c}
}
- # wallpaper
+ if $::plain_unix {
+ # plain_unix: avoid a possible RenderBadPicture error on quitting
+ # when there is a menu.
+ # 'send' bypasses the bug by changing the shutdown sequence.
+ # 'tk appname <something>' restores 'send'.
+ bind . <Destroy> {
+ catch {tk appname appname}
+ }
+ }
+
+ # menu, for language selection and font scaling
+ menu .mn
+ . configure -menu .mn
+ if $::plain_unix {
+ .mn configure -borderwidth 1
+ .mn configure -background $::default_bg
+ }
+ menu .mn.file
+ .mn add cascade -label [__ "File"] -menu .mn.file
+ .mn.file add command -command abort_menu -label [__ "Abort"]
+
+ menu .mn.gui
+ .mn add cascade -label [__ "GUI"] -menu .mn.gui
+
+
+ if {[llength $::langs] > 1} {
+ menu .mn.gui.lang
+ .mn.gui add cascade -label [__ "Language"] -menu .mn.gui.lang
+ foreach l [lsort $::langs] {
+ if {$l eq $::lang} {
+ set mlabel "$l *"
+ } else {
+ set mlabel $l
+ }
+ .mn.gui.lang add command -label $mlabel -command "set_language $l"
+ }
+ }
+
+ menu .mn.gui.fscale
+ .mn.gui add cascade -label [__ "Font scaling"] -menu .mn.gui.fscale
+ foreach s {0.5 0.7 1 1.25 1.5 2 3 4 6 8} {
+ if {$s eq $::tkfontscale} {
+ set mlabel "$s *"
+ } else {
+ set mlabel $s
+ }
+ .mn.gui.fscale add command -label $mlabel -command "set_fontscale $s"
+ }
+
+ # wallpaper, for a uniform background
pack [ttk::frame .bg -padding 3] -fill both -expand 1
# title
Modified: trunk/Master/tlpkg/tltcl/tltcl.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/tltcl.tcl 2020-04-20 23:55:21 UTC (rev 54822)
+++ trunk/Master/tlpkg/tltcl/tltcl.tcl 2020-04-21 11:51:02 UTC (rev 54823)
@@ -205,8 +205,16 @@
# Otherwise, the localization code borrows much from Norbert Preining's
# translation module for TL.
-proc load_translations {} {
+package require msgcat
+# available languages
+set ::langs [list "en"]
+foreach l [glob -nocomplain -directory \
+ [file join $::instroot "tlpkg" "translations"] *.po] {
+ lappend ::langs [string range [file tail $l] 0 end-3]
+}
+
+proc initialize_language {} {
# check the command-line for a lang parameter
set ::lang ""
set i 0
@@ -222,35 +230,17 @@
}
unset i
- # First fallback: check config file.
- # $TEXMFCONFIG/tlmgr/config can have a setting for gui-lang.
- # There will not be one for the installer, only for tlmgr.
- if {! [info exists ::lang] || $::lang eq ""} {
- foreach tmf {"TEXMFCONFIG" "TEXMFSYSCONFIG"} {
- if [catch {exec kpsewhich -var-value $tmf} d] {
- break; # apparently there is not yet a TL installation
- }
- if [catch {open [file join $d "tlmgr" "config"] r} fid] continue
- while 1 {
- if [chan eof $fid] {
- break
- }
- if [catch {chan gets $fid} l] break
- if {[regexp {^\s*gui-lang\s*=\s*(\S+)$} $l m ::lang]} {
- break
- }
- }
- chan close $fid
- if {[info exists ::lang] && $::lang ne ""} break
- }
+ # First fallback, only for tlshell: check tlmgr config file
+ if {$::lang eq "" && [info exists ::invoker] && $::invoker eq "tlshell"} {
+ set ::lang [get_config_var "gui-lang"]
}
+ # try to set tcltk's locale to $::lang too. this may not work for 8.5.
+ if {$::lang ne ""} {::msgcat::mclocale $::lang}
+
# second fallback: what does msgcat think about it? Note that
# msgcat checks the environment and on windows also the registry.
- if {! [info exists ::lang] || $::lang eq ""} {
- package require msgcat
- set ::lang [::msgcat::mclocale]
- }
+ if {$::lang eq ""} {set ::lang [::msgcat::mclocale]}
set messcat ""
if {$::lang ne ""} {
@@ -264,20 +254,29 @@
set messcat $f
break
} elseif {[string range $ln_f 0 1] eq [string range $::lang 0 1]} {
- set ::lang [string range $::lang 0 1]
set maybe $f
}
}
- if {$messcat eq ""} {
- set messcat $maybe
+ if {$messcat eq "" && $maybe ne ""} {
+ set ::lang [string tolower [string range [file tail $maybe] 0 end-3]]
}
}
+}
+initialize_language
+proc load_translations {} {
+ foreach s [array names ::TRANS] {
+ array unset ::TRANS $s
+ }
+ if {$::lang eq ""} return
+ set messcat [file join $::instroot "tlpkg" "translations" "${::lang}.po"]
# parse messcat.
- # for now, just skip lines which make no sense.
- # empty messcat: no suitable message catalog
- if {$messcat ne ""} {
+ # skip lines which make no sense
+ if [file exists $messcat] {
# create array with msgid keys and msgstr values
+ # in the case that we switch languages,
+ # we need to remove old translations,
+ # since the new set may not completely cover the old one
if {! [catch {open $messcat r} fid]} {
fconfigure $fid -encoding utf-8
set inmsgid 0
@@ -340,6 +339,7 @@
}
}
}
+initialize_language
load_translations
proc __ {s args} {
@@ -372,36 +372,97 @@
### fonts ###
-# no bold text for messages; `userDefault' indicates priority
-option add *Dialog.msg.font TkDefaultFont userDefault
+# ttk defaults use TkDefaultFont and TkHeadingFont
+# ttk classic theme also uses TkTextFont for TEntry
+# ttk::combobox uses TkTextFont
+# although only the first three appear to be used here, this may depend
+# on the theme, so I resize all symbolic fonts anyway.
-# normal size bold
-font create bfont {*}[font configure TkDefaultFont]
-font configure bfont -weight bold
-# larger, not bold: lfont
-font create lfont {*}[font configure TkDefaultFont]
-font configure lfont -size [expr {round(1.2 * [font actual lfont -size])}]
-# larger and bold
-font create hfont {*}[font configure lfont]
-font configure hfont -weight bold
-# extra large and bold
-font create titlefont {*}[font configure TkDefaultFont]
-font configure titlefont -weight bold \
- -size [expr {round(1.5 * [font actual titlefont -size])}]
+set dflfonts [list \
+ TkHeadingFont \
+ TkCaptionFont \
+ TkDefaultFont \
+ TkMenuFont \
+ TkTextFont \
+ TkTooltipFont \
+ TkFixedFont \
+ TkIconFont \
+ TkSmallCaptionFont \
+]
+foreach f $::dflfonts {
+ set ::oldsize($f) [font configure $f -size]
+}
-## italicized items; not used
-#font create it_font {*}[font configure TkDefaultFont]
-#font configure it_font -slant italic
+font create bfont
+font create lfont
+font create hfont
+font create titlefont
-# width of '0', as a very rough estimate of average character width
-set ::cw \
+proc redo_fonts {} {
+
+ # note that ttk styles refer to the above symbolic font names
+ # and generally do not define fonts themselves
+
+ foreach f $::dflfonts {
+ font configure $f -size [expr { round($::oldsize($f)*$::tkfontscale)}]
+ }
+ # the above works for ttk::*button, ttk::treeview, notebook labels
+ unset -nocomplain f
+
+ option add *font TkDefaultFont
+ # the above works for menu items, ttk::label, text, ttk::entry
+ # including current value of ttk::combobox, ttk::combobox list items
+ # and non-ttk labels and buttons - which are not used here
+
+ set ::cw \
[expr {max([font measure TkDefaultFont "0"],[font measure TkTextFont "0"])}]
+ # height: assume height == width*2
+ # workaround for treeview on windows on HiDPI displays
+ ttk::style configure Treeview -rowheight [expr {3 * $::cw}]
-# height: assume height == width*2
+ # no bold text for messages; `userDefault' indicates priority
+ option add *Dialog.msg.font TkDefaultFont userDefault
-# workaround for treeview on windows on HiDPI displays
-ttk::style configure Treeview -rowheight [expr {3 * $::cw}]
+ # normal size bold
+ font configure bfont {*}[font configure TkDefaultFont]
+ font configure bfont -weight bold
+ # larger, not bold: lfont
+ font configure lfont {*}[font configure TkDefaultFont]
+ font configure lfont -size [expr {round(1.2 * [font actual lfont -size])}]
+ # larger and bold
+ font configure hfont {*}[font configure lfont]
+ font configure hfont -weight bold
+ # extra large and bold
+ font configure titlefont {*}[font configure TkDefaultFont]
+ font configure titlefont -weight bold \
+ -size [expr {round(1.5 * [font actual titlefont -size])}]
+}
+# initialize scaling factor
+
+set ::tkfontscale ""
+if {[info exists ::invoker] && $::invoker eq "tlshell"} {
+ set ::tkfontscale [get_config_var "tkfontscale"]
+ # is $::tkfontscale a number, and a reasonable one?
+ if {[scan $::tkfontscale {%f} f] != 1} { ; # not a number
+ set ::tkfontscale ""
+ } elseif {$::tkfontscale < 0} {
+ set ::tkfontscale ""
+ } elseif {$::tkfontscale < 0.5} {
+ set ::tkfontscale 0.5
+ } elseif {$::tkfontscale > 10} {
+ set ::tkfontscale 10
+ }
+}
+if {$::tkfontscale eq ""} {
+ if {[winfo vrootheight .] > 2000 && [winfo vrootwidth .] > 3000} {
+ set ::tkfontscale 2
+ } else {
+ set ::tkfontscale 1
+ }
+}
+redo_fonts
+
# icon
catch {
image create photo tl_logo -file \
More information about the tex-live-commits
mailing list.