From e783b071ded7eef421d0333416b47142bc5542cb Mon Sep 17 00:00:00 2001 From: Siep Kroonenberg Date: Tue, 21 Apr 2020 11:51:02 +0000 Subject: GUI font scaling; change language and font size on the fly git-svn-id: svn://tug.org/texlive/trunk@54823 c570f23f-e606-0410-a88d-b1316a301751 --- Master/texmf-dist/scripts/tlshell/tlshell.tcl | 367 ++++++++++++++++---------- Master/tlpkg/installer/install-tl-gui.tcl | 99 +++++-- Master/tlpkg/tltcl/tltcl.tcl | 179 ++++++++----- 3 files changed, 429 insertions(+), 216 deletions(-) diff --git a/Master/texmf-dist/scripts/tlshell/tlshell.tcl b/Master/texmf-dist/scripts/tlshell/tlshell.tcl index 24ae2ea74ae..e0e10993713 100755 --- a/Master/texmf-dist/scripts/tlshell/tlshell.tcl +++ b/Master/texmf-dist/scripts/tlshell/tlshell.tcl @@ -26,7 +26,79 @@ if {$::tcl_platform(platform) ne "windows"} { 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 @@ set ddebug 0 # 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,7 +274,44 @@ proc any_message {str type {p "."}} { } } ; # 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 @@ proc total_dis_enable {y_n} { } } ; # 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 @@ proc run_cmd_waiting {cmd} { # 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 @@ proc is_updatable {nm} { 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 @@ proc update_globals {} { 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 @@ proc collect_filtered {} { 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 @@ proc set_repos_in_tlmgr {} { }; # 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 @@ proc save_load_repo {} { # 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 @@ if {$::tcl_platform(platform) ne "windows"} { run_cmds $cmds 1 vwait ::done_waiting update_local_revnumbers - collect_filtered + collect_and_display_filtered } ; # platforms_do @@ -1411,7 +1491,7 @@ proc finish_restore {} { # 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 @@ proc update_tlmgr {} { 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 @@ proc update_all {} { vwait ::done_waiting update_local_revnumbers } - collect_filtered + collect_and_display_filtered } ; # update_all ### doing something with some packages @@ -1688,7 +1768,7 @@ proc install_pkgs {sel_opt {pk ""}} { } 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 @@ proc update_pkgs {sel_opt {pk ""}} { } 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 @@ proc remove_pkgs {sel_opt {pk ""}} { } 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,46 +1988,25 @@ proc set_paper {p} { 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"] + } } } @@ -1956,7 +2015,7 @@ proc set_language {l} { # 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 @@ proc read_capt {} { lappend ::out_log $l log_widget_add $l } -}; # read_capt +}; # read_capture proc run_external {cmd mess} { set ::out_log {} @@ -1982,10 +2041,16 @@ proc run_external {cmd mess} { 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 show_help {} { 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 @@ proc populate_main {} { 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 @@ proc populate_main {} { .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 ' 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 ' restores 'send'. bind . { catch {tk appname appname} } @@ -2099,18 +2161,35 @@ proc populate_main {} { 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 @@ proc populate_main {} { .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 @@ proc populate_main {} { # 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 @@ proc populate_main {} { # 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 @@ proc populate_main {} { 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 @@ proc initialize {} { 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 @@ proc initialize {} { 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 diff --git a/Master/tlpkg/installer/install-tl-gui.tcl b/Master/tlpkg/installer/install-tl-gui.tcl index cd9001ea836..e831f8984be 100755 --- a/Master/tlpkg/installer/install-tl-gui.tcl +++ b/Master/tlpkg/installer/install-tl-gui.tcl @@ -45,7 +45,12 @@ set ::instroot [file normalize [info script]] 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 @@ proc make_splash {} { # 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 @@ proc select_binaries {} { ppack .tlbin.cancel -in .tlbin.buts -side right bind .tlbin {.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 @@ proc select_scheme {} { bind .tlschm {.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 @@ if {$::tcl_platform(platform) ne "windows"} { ############################################################# +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 @@ if {$::tcl_platform(platform) ne "windows"} { # 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 @@ proc run_menu {} { 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 ' restores 'send'. + bind . { + 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 diff --git a/Master/tlpkg/tltcl/tltcl.tcl b/Master/tlpkg/tltcl/tltcl.tcl index fdb9deef729..e95f919d7f1 100644 --- a/Master/tlpkg/tltcl/tltcl.tcl +++ b/Master/tlpkg/tltcl/tltcl.tcl @@ -205,8 +205,16 @@ normalize_argv # 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 @@ proc load_translations {} { } 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 @@ proc load_translations {} { 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 @@ proc load_translations {} { } } } +initialize_language load_translations proc __ {s args} { @@ -372,35 +372,96 @@ unset -nocomplain ::env(LANGUAGE) ### fonts ### -# no bold text for messages; `userDefault' indicates priority -option add *Dialog.msg.font TkDefaultFont userDefault - -# 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])}] - -## italicized items; not used -#font create it_font {*}[font configure TkDefaultFont] -#font configure it_font -slant italic - -# width of '0', as a very rough estimate of average character width -set ::cw \ - [expr {max([font measure TkDefaultFont "0"],[font measure TkTextFont "0"])}] +# 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. + +set dflfonts [list \ + TkHeadingFont \ + TkCaptionFont \ + TkDefaultFont \ + TkMenuFont \ + TkTextFont \ + TkTooltipFont \ + TkFixedFont \ + TkIconFont \ + TkSmallCaptionFont \ +] +foreach f $::dflfonts { + set ::oldsize($f) [font configure $f -size] +} + +font create bfont +font create lfont +font create hfont +font create titlefont + +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 -# height: assume height == width*2 + 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 -# workaround for treeview on windows on HiDPI displays -ttk::style configure Treeview -rowheight [expr {3 * $::cw}] + 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}] + + # no bold text for messages; `userDefault' indicates priority + option add *Dialog.msg.font TkDefaultFont userDefault + + # 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 { -- cgit v1.2.3