diff options
author | Siep Kroonenberg <siepo@cybercomm.nl> | 2018-11-14 15:20:33 +0000 |
---|---|---|
committer | Siep Kroonenberg <siepo@cybercomm.nl> | 2018-11-14 15:20:33 +0000 |
commit | 6fa567467b86f28fa2fcb9e0f85bd91eface730d (patch) | |
tree | 809be2a89575bc39cf3e5bba75536efec67c4ce7 /Master/tlpkg/TeXLive | |
parent | b706d0051d16f8ce033d1d6a001c9ba337f26d0c (diff) |
Integrating tcl installer; UAC prompt for tlshell
git-svn-id: svn://tug.org/texlive/trunk@49155 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/TeXLive')
-rw-r--r-- | Master/tlpkg/TeXLive/tltcl.tcl | 507 |
1 files changed, 0 insertions, 507 deletions
diff --git a/Master/tlpkg/TeXLive/tltcl.tcl b/Master/tlpkg/TeXLive/tltcl.tcl deleted file mode 100644 index 75e9c12e724..00000000000 --- a/Master/tlpkg/TeXLive/tltcl.tcl +++ /dev/null @@ -1,507 +0,0 @@ -#!/usr/bin/env wish - -# Copyright 2018 Siep Kroonenberg - -# This file is licensed under the GNU General Public License version 2 -# or any later version. - -# common declarations for tlshell.tcl and install-tl-gui.tcl - -set ::plain_unix 0 -if {$::tcl_platform(platform) eq "unix" && $::tcl_platform(os) ne "Darwin"} { - set ::plain_unix 1 -} - -# process ID of the perl program that will run in the background -set ::perlpid 0 - -set any_mirror "http://mirror.ctan.org/systems/texlive/tlnet" - -proc get_stacktrace {} { - set level [info level] - set s "" - for {set i 1} {$i < $level} {incr i} { - append s [format "Level %u: %s\n" $i [info level $i]] - } - return $s -} ; # get_stacktrace - -proc err_exit {{mess ""}} { - if {$mess eq ""} {set mess "Error"} - append mess "\n" [get_stacktrace] - if $::plain_unix { - # 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 - bind . <Destroy> { - catch {tk appname appname} - } - } - tk_messageBox -icon error -message $mess - # kill perl process, just in case - if $::perlpid { - catch { - if {$::tcl_platform(platform) eq "unix"} { - exec -ignorestderr "kill" $::perlpid - } else { - exec -ignorestderr "taskkill" "/pid" $::perlpid - } - } - } - exit -} ; # err_exit - -# localization support - -# for the sake of our translators we use our own translation function -# which can use .po files directly. This allows them to check their work -# without creating or waiting for a conversion to .msg. -# We still use the msgcat module for detecting default locale. -# Otherwise, the localization code borrows much from Norbert Preining's -# translation module for TL. - -proc load_translations {} { - - # check the command-line for a lang parameter - set ::lang "" - set i 0 - while {$i < $::argc} { - set p [lindex $::argv $i] - incr i - if {$p eq "-lang" || $p eq "--lang"} { - if {$i < $::argc} { - set ::lang [lindex $::argv $i] - break - } - } elseif {[string range $p 0 5] eq "-lang="} { - set ::lang [string range $p 6 end] - break - } elseif {[string range $p 0 6] eq "--lang="} { - set ::lang [string range $p 7 end] - break - } - } - 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 - } - } - - # 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] - } - - set messcat "" - if {$::lang ne ""} { - set messcat "" - set maybe "" - set ::lang [string tolower $::lang] - set tdir [file join $::instroot "tlpkg" "translations"] - foreach f [glob -directory $tdir *.po] { - set ln_f [string tolower [string range [file tail $f] 0 end-3]] - if {$ln_f eq $::lang} { - set messcat $f - break - } elseif {[string range $ln_f 0 1] eq [string range $::lang 0 1]} { - set maybe $f - } - } - if {$messcat eq ""} { - set messcat $maybe - } - } - - # parse messcat. - # for now, just skip lines which make no sense. - # empty messcat: no suitable message catalog - if {$messcat ne ""} { - # create array with msgid keys and msgstr values - if {! [catch {open $messcat r} fid]} { - fconfigure $fid -encoding utf-8 - set inmsgid 0 - set inmsgstr 0 - set msgid "" - set msgstr "" - while 1 { - if [chan eof $fid] break - if [catch {chan gets $fid} l] break - if [regexp {^\s*#} $l] continue - if [regexp {^\s*$} $l] { - # empty line separates msgid/msgstr pairs - if $inmsgid { - # msgstr lines missing - # puts stderr "no translation for $msgid in $messcat" - set msgid "" - set msgstr "" - set inmsgid 0 - set inmsgstr 0 - continue - } - if $inmsgstr { - # empty line signals end of msgstr - if {$msgstr ne ""} { - set msgid [string map {"\\n" "\n"} $msgid] - set msgstr [string map {"\\n" "\n"} $msgstr] - set msgid [string map {"\\\\" "\\"} $msgid] - set msgstr [string map {"\\\\" "\\"} $msgstr] - set ::TRANS($msgid) $msgstr - } - set msgid "" - set msgstr "" - set inmsgid 0 - set inmsgstr 0 - continue - } - continue - } ; # empty line - if [regexp {^msgid\s+"(.*)"\s*$} $l m msgid] { - # note. a failed match will leave msgid alone - set inmsgid 1 - continue - } - if [regexp {^"(.*)"\s*$} $l m s] { - if $inmsgid { - append msgid $s - } elseif $inmsgstr { - append msgstr $s - } - continue - } - if [regexp {^msgstr\s+"(.*)"\s*$} $l m msgstr] { - set inmsgstr 1 - set inmsgid 0 - } - } - chan close $fid - } - } -} -load_translations - -proc __ {s args} { - if {[info exists ::TRANS($s)]} { - set s $::TRANS($s) - #} else { - # puts stderr "No translation found for $s\n[get_stacktrace]" - } - if {$args eq ""} { - return $s - } else { - return [format $s {*}$args] - } -} - -# string representation of booleans -proc yes_no {b} { - if $b { - set ans [__ "Yes"] - } else { - set ans [__ "No"] - } - return $ans -} - -if {$::tcl_platform(os) eq "Darwin"} { - # avoid warnings 'tar: Failed to set default locale' - set ::env(LC_ALL) "en_US.UTF-8" -} - -### 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 -# assume height == width*2 -set ::cw [font measure TkDefaultFont "0"] - -# default foreground color and disabled foreground color -# may not be black in e.g. dark color schemes -set blk [ttk::style lookup TButton -foreground] -set gry [ttk::style lookup TButton -foreground disabled] - -# 'default' padding - -proc ppack {wdg args} { ; # pack command with padding - pack $wdg {*}$args -padx 3 -pady 3 -} - -proc pgrid {wdg args} { ; # grid command with padding - grid $wdg {*}$args -padx 3 -pady 3 -} - -# unicode symbols as fake checkboxes in ttk::treeview widgets - -proc mark_sym {mrk} { - if {$::tcl_platform(platform) eq "windows"} { - # under windows, these look slightly better than - # the non-windows selections - if $mrk { - return "\u25C9" ; # 'fisheye' - } else { - return "\u25CB" ; # 'white circle' - } - } else { - if $mrk { - return "\u25A3" ; # 'white square containing black small square' - } else { - return "\u25A1" ; # 'white square' - } - } -} ; # mark_sym - -# for help output -set ::env(NOPERLDOC) 1 - -##### dialog support ##### - -# for example code, look at dialog.tcl, part of Tk itself - -# global variable for dialog return value, in case the outcome -# must be handled by the caller rather than by the dialog itself: -set ::dialog_ans {} - -# start new toplevel with settings appropriate for a dialog -proc create_dlg {wnd {p .}} { - unset -nocomplain ::dialog_ans - catch {destroy $wnd} ; # no error if it does not exist - toplevel $wnd -class Dialog - wm withdraw $wnd - if [winfo viewable $p] {wm transient $wnd $p} - if $::plain_unix {wm attributes $wnd -type dialog} - wm protocol $wnd WM_DELETE_WINDOW {destroy $wnd} -} - -# Place a dialog centered wrt its parent. -# If its geometry is somehow not yet available, -# its upperleft corner will be centered. - -proc place_dlg {wnd {p "."}} { - set g [wm geometry $p] - scan $g "%dx%d+%d+%d" pw ph px py - set hcenter [expr {$px + $pw / 2}] - set vcenter [expr {$py + $ph / 2}] - set g [wm geometry $wnd] - set wh [winfo reqheight $wnd] - set ww [winfo reqwidth $wnd] - set wx [expr {$hcenter - $ww / 2}] - if {$wx < 0} { set wx 0} - set wy [expr {$vcenter - $wh / 2}] - if {$wy < 0} { set wy 0} - wm geometry $wnd [format "+%d+%d" $wx $wy] - wm state $wnd normal - wm attributes $wnd -topmost - raise $wnd $p - tkwait visibility $wnd - focus $wnd - grab set $wnd -} ; # place_dlg - -proc end_dlg {ans wnd} { - set ::dialog_ans $ans - set p [winfo parent $wnd] - if {$p eq ""} {set p "."} - raise $p - destroy $wnd -} ; # end_dlg - -##### directories ##### - -# slash flipping -proc forward_slashify {s} { - regsub -all {\\} $s {/} r - return $r -} -proc native_slashify {s} { - if {$::tcl_platform(platform) eq "windows"} { - regsub -all {/} $s {\\} r - } else { - regsub -all {\\} $s {/} r - } - return $r -} - -# unix: choose_dir replacing native directory browser - -if {$::tcl_platform(platform) eq "unix"} { - - # Based on the tcl/tk widget demo. - # Also for MacOS, because we want to see /usr. - # For windows, the native browser widget is better. - - ## Code to populate a single directory node - proc populateTree {tree node} { - if {[$tree set $node type] ne "directory"} { - set type [$tree set $node type] - return - } - $tree delete [$tree children $node] - foreach f [lsort [glob -nocomplain -directory $node *]] { - set type [file type $f] - if {$type eq "directory"} { - $tree insert $node end \ - -id $f -text [file tail $f] -values [list $type] - # Need at least one child to make this node openable, - # will be deleted when actually populating this node - $tree insert $f 0 -text "dummy" - } - } - # Stop this code from rerunning on the current node - $tree set $node type processedDirectory - } - - proc choose_dir {initdir {parent .}} { - - create_dlg .browser $parent - wm title .browser [__ "Browse..."] - - # wallpaper - pack [ttk::frame .browser.bg -padding 3] -fill both -expand 1 - ## Create the tree and set it up - pack [ttk::frame .browser.fr0] -in .browser.bg -fill both -expand 1 - set tree [ttk::treeview .browser.tree \ - -columns {type} -displaycolumns {} -selectmode browse \ - -yscroll ".browser.vsb set"] - .browser.tree column 0 -minwidth 500 -stretch 0 - ttk::scrollbar .browser.vsb -orient vertical -command "$tree yview" - # hor. scrolling does not work, but toplevel and widget are resizable - $tree heading \#0 -text "/" - $tree insert {} end -id "/" -text "/" -values [list "directory"] - - populateTree $tree "/" - bind $tree <<TreeviewOpen>> { - populateTree %W [%W focus] - } - bind $tree <ButtonRelease-1> { - .browser.tree heading \#0 -text [%W focus] - } - - ## Arrange the tree and its scrollbar in the toplevel - # horizontal scrolling does not work. - # possible solution: very wide treeview in smaller paned window - # (may as well use pack in the absence of a horizontal scrollbar) - grid $tree .browser.vsb -sticky nsew -in .browser.fr0 - grid columnconfigure .browser.fr0 0 -weight 1 - grid rowconfigure .browser.fr0 0 -weight 1 - - # ok and cancel buttons - pack [ttk::frame .browser.fr1] -in .browser.bg -fill x -expand 1 - ppack [ttk::button .browser.ok -text [__ "Ok"]] \ - -in .browser.fr1 -side right - ppack [ttk::button .browser.cancel -text [__ "Cancel"]] \ - -in .browser.fr1 -side right - .browser.ok configure -command { - set ::dialog_ans [.browser.tree focus] - destroy .browser - } - .browser.cancel configure -command { - set ::dialog_ans "" - destroy .browser - } - unset -nocomplain ::dialog_ans - - # navigate tree to $initdir - set chosenDir {} - foreach d [file split [file normalize $initdir]] { - set nextdir [file join $chosenDir $d] - if [file isdirectory $nextdir] { - if {! [$tree exists $nextdir]} { - $tree insert $chosenDir end -id $nextdir \ - -text $d -values [list "directory"] - } - populateTree $tree $nextdir - set chosenDir $nextdir - } else { - break - } - } - $tree see $chosenDir - $tree selection set [list $chosenDir] - $tree focus $chosenDir - $tree heading \#0 -text $chosenDir - - place_dlg .browser $parent - tkwait window .browser - return $::dialog_ans - }; # choose_dir - -}; # if unix - -proc browse4dir {inidir {parent .}} { - if {$::tcl_platform(platform) eq "unix"} { - return [choose_dir $inidir $parent] - } else { - return [tk_chooseDirectory \ - -initialdir $inidir -title [__ "Select or type"] -parent $parent] - } -} ; # browse4dir - -# browse for a directory and store in entry- or label widget $w -proc dirbrowser2widget {w} { - set wclass [winfo class $w] - if {$wclass eq "Entry" || $wclass eq "TEntry"} { - set is_entry 1 - } elseif {$wclass eq "Label" || $wclass eq "TLabel"} { - set is_entry 0 - } else { - err_exit "browse2widget invoked with unsupported widget class $wclass" - } - if $is_entry { - set retval [$w get] - } else { - set retval [$w cget -text] - } - set retval [browse4dir $retval [winfo parent $w]] - if {$retval eq ""} { - return 0 - } else { - if {$wclass eq "Entry" || $wclass eq "TEntry"} { - $w delete 0 end - $w insert 0 $retval - } else { - $w configure -text $retval - } - return 1 - } -} |