From e0c6872cf40896c7be36b11dcc744620f10adf1d Mon Sep 17 00:00:00 2001 From: Norbert Preining Date: Mon, 2 Sep 2019 13:46:59 +0900 Subject: Initial commit --- .../tlnet/tlpkg/installer/install-tl-gui.tcl | 2063 ++++++++++++++++++++ 1 file changed, 2063 insertions(+) create mode 100644 systems/texlive/tlnet/tlpkg/installer/install-tl-gui.tcl (limited to 'systems/texlive/tlnet/tlpkg/installer/install-tl-gui.tcl') diff --git a/systems/texlive/tlnet/tlpkg/installer/install-tl-gui.tcl b/systems/texlive/tlnet/tlpkg/installer/install-tl-gui.tcl new file mode 100644 index 0000000000..69a653fc87 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/installer/install-tl-gui.tcl @@ -0,0 +1,2063 @@ +#!/usr/bin/env wish + +# Copyright 2018, 2019 Siep Kroonenberg + +# This file is licensed under the GNU General Public License version 2 +# or any later version. + +# Tcl/Tk frontend for TeX Live installer + +# Installation can be divided into three stages: +# +# 1. preliminaries. This stage may involve some interaction with the user, +# which can be channeled through message boxes +# 2. a menu +# 3. the actual installation +# +# During stage 1. and 3. this wrapper collects stdout and stderr from +# the perl installer, with stderr being redirected to stdout. +# This output will be displayed in a text widget during stage 3, +# and in debug mode also in stage 1. +# During stage 3, we shall use event-driven, non-blocking I/O, which is +# needed for a scrolling display of installer output. +# +# Main window: +# filled successively with: +# - a logo, and 'loading...' label, by way of splash +# - a menu for stage 2 +# - a log text widget for tracking stage 3 +# ::out_log should be cleared before stage 3. +# +# In profile mode, the menu stage is skipped. + +package require Tk + +# security: disable send +catch {rename send {}} + +# This file should be in $::instroot/tlpkg/installer. +# On non-windows platforms, install-tl functions as a wrapper +# for this file if it encounters a parameter '-gui tcl'. +# This allows automatic inclusion of a '--' parameter to separate +# tcl parameters from script parameters. + +set ::instroot [file normalize [info script]] +set ::instroot [file dirname [file dirname [file dirname $::instroot]]] + +# declarations, initializations and procs shared with tlshell.tcl +source [file join $::instroot "tlpkg" "tltcl" "tltcl.tcl"] + +### initialize some globals ### + +# perl installer process id +set ::perlpid 0 + +set ::out_log {}; # list of strings + +set ::perlbin "perl" +if {$::tcl_platform(platform) eq "windows"} { + # the batch wrapper should have put perl.exe on the searchpath + set ::perlbin "perl.exe" +} + +# menu modes +set ::advanced 0 +set ::alltrees 0 + +# interactively select repository +set ::select_repo 0 + +proc kill_perl {} { + if $::perlpid { + catch { + if {$::tcl_platform(platform) eq "unix"} { + exec -ignorestderr kill $::perlpid >& /dev/null + } else { + exec -ignorestderr taskkill /pid $::perlpid /t /f + } + } + } +} + +proc err_exit {{mess ""}} { + if {$mess eq ""} {set mess "Error"} + append mess "\n" [get_stacktrace] + tk_messageBox -icon error -message $mess + # kill perl process, just in case + kill_perl + exit +} ; # err_exit + +# warning about non-empty target tree +set ::td_warned 0 + +proc is_nonempty {td} { + if {! [file exists $td]} {return 0} + return [expr {[llength [glob -nocomplain -directory $td *]] > 0}] +} + +proc td_warn {td} { + set ans [tk_messageBox -icon warning -type ok \ + -message [__ "Target directory %s non-empty;\nmay cause trouble!" $td]] + set ::td_warned 1 +} + +proc td_question {td} { + set ans [tk_messageBox -icon warning -type yesno \ + -message [__ "Target directory %s non-empty;\nare you sure?" $td]] + set ::td_warned 1 + return $ans +} + +### procedures, mostly organized bottom-up ### + +# the procedures which provide the menu with the necessary backend data, +# i.e. read_descs, read_vars and read_menu_data, are defined near the end. + +set clock0 [clock milliseconds] +set profiling 0 +proc show_time {s} { + if $::profiling { + puts [format "%s: %d" $s [expr {[clock milliseconds] - $::clock0}]] + } +} + +# for debugging frontend-backend communication: +# write to a logfile which is shared with the backend. +# both parties open, append and close every time. + +set dblogdir "/tmp" +if [info exists ::env(TMPDIR)] { + set dblogdir $::env(TMPDIR) +} elseif [info exists ::env(TMP)] { + set dblogdir $::env(TMP) +} elseif [info exists ::env(TEMP)] { + set dblogdir $::env(TEMP) +} +set ::dblfile [file join $dblogdir "dblog"] +unset dblogdir + +proc dblog {s} { + set db [open $::dblfile a] + set t [get_stacktrace] + puts $db "TCL: $s\n$t" + close $db +} + +proc maybe_print_welcome {} { + # if the last non-empty line was "All done", then installation is completed. + # otherwise, it was help output or an interrupted installation. + # we allow for spurious empty lines at the end of the backend output. + + set all_done 0 + for {set i [.log.tx count -lines 1.0 end]} {$i > 0} {incr i -1} { + set l [.log.tx get ${i}.0 ${i}.end] + if {$l ne ""} { + if {[string range $l 0 11] eq "Installed on"} { + set all_done 1 + } + break + } + } + if {!$all_done} return + # need TEXDIR and this_platform in case of profile install + if {! [info exists ::vars(this_platform)] || \ + ! [info exists ::vars(TEXDIR)]} { + if [regexp {^Installed on platform (.*) at (.*)$} $l m p r] { + set ::vars(this_platform) $p + set ::vars(TEXDIR) $r + } else { + set ::vars(this_platform) "PLATFORM" + set ::vars(TEXDIR) "ROOT" + } + } + + .log.tx configure -state normal + .log.tx tag configure center -justify center + .log.tx delete ${i}.0 end + .log.tx insert end "\n\n" + .log.tx insert end [__ "Welcome to TeX Live!"] center + .log.tx insert end "\n\n" + # tags appear to interfere with --/::msgcat::mc !?! + set s [__ "See %s/index.html for links to documentation.\nThe TeX Live web site (https://tug.org/texlive/) contains any updates and corrections. TeX Live is a joint project of the TeX user groups around the world; please consider supporting it by joining the group best for you. The list of groups is available on the web at https://tug.org/usergroups.html." $::vars(TEXDIR)] + .log.tx insert end $s center + if {$::tcl_platform(platform) ne "windows"} { + .log.tx insert end "\n\n" + set s [__ "Add %s/texmf-dist/doc/man to MANPATH.\nAdd %s/texmf-dist/doc/info to INFOPATH.\nMost importantly, add %s/bin/%s\nto your PATH for current and future sessions." $::vars(TEXDIR) $::vars(TEXDIR) $::vars(TEXDIR) $::vars(this_platform)] + .log.tx insert end $s center + } + .log.tx insert end "\n" + .log.tx yview moveto 1 + if {$::tcl_platform(os) ne "Darwin"} {.log.tx configure -state disabled} +} + +# regular read_line +proc read_line {} { + while 1 { + if [catch {chan gets $::inst l} len] { + # catch [chan close $::inst] + err_exit " +Error while reading from Perl back end. +This should not have happened!" + } elseif {$len < 0} { + # catch [chan close $::inst] + return [list -1 ""] + } elseif {[string range $l 0 1] eq "D:" || [string range $l 0 2] eq "DD:" \ + || [string range $l 0 3] eq "DDD:"} { + lappend ::out_log $l + } else { + return [list $len $l] + } + } +}; # read_line + +proc read_line_no_eof {} { + set ll [read_line] + if {[lindex $ll 0] < 0} { + log_exit " +Unexpected closed backend. +This should not have happened!" + } + set l [lindex $ll 1] + # TODO: test under debug mode + return $l +}; # read_line_no_eof + +# non-blocking i/o: callback for "readable" while the splash screen is up +# and the back end tries to contact the repository +proc read_line_loading {} { + set l "" ; # will contain the line to be read + if {([catch {chan gets $::inst l} len] || [chan eof $::inst])} { + catch {chan close $::inst} + # note. the normal way to terminate is terminating the GUI shell. + # This closes stdin of the child + } elseif {$len >= 0} { + if {$l eq "endload"} { + chan configure $::inst -blocking 1 + chan event $::inst readable {} + set ::loaded 1 + } + } +}; # read_line_loading + +# non-blocking i/o: callback for "readable" during stage 3, installation +# ::out_log should no longer be needed +proc read_line_cb {} { + set l "" ; # will contain the line to be read + if {([catch {chan gets $::inst l} len] || [chan eof $::inst])} { + catch {chan close $::inst} + # note. the normal way to terminate is terminating the GUI shell. + # This closes stdin of the child + .close state !disabled + if [winfo exists .abort] {.abort state disabled} + maybe_print_welcome + } elseif {$len >= 0} { + # regular output + .log.tx configure -state normal + .log.tx insert end "$l\n" + .log.tx yview moveto 1 + if {$::tcl_platform(os) ne "Darwin"} {.log.tx configure -state disabled} + } +}; # read_line_cb + +proc maybe_abort {} { + set ans [tk_messageBox -message [__ "Really abort?"] -type yesno \ + -default no] + if {$ans eq "no"} { + return + } + catch {chan close $::inst} + kill_perl + exit +} + +# modify parameter list for either restarting gui installer +# or for starting back end + +proc replace_lang_parameter {} { + # edit original command line by removing any language parameter + # and adding a repository parameter $m. same for language + set i [llength $::argv] + while {$i > 0} { + incr i -1 + set p [lindex $::argv $i] + if {$p eq "-lang" || $p eq "-gui-lang"} { + set j [expr {$i+1}] + if {$j < [llength $::argv]} { + set ::argv [lreplace $::argv $i $j] + } else { + set ::argv [lreplace $::argv $i] + } + set ::argv [lreplace $::argv $i [expr {$i+1}]] + } + } + lappend ::argv "-lang" $::lang +} + +proc replace_repo_parameter {m} { + # edit original command line by removing any repository parameter + # and adding a repository parameter $m. same for language + set i $::argc + while {$i > 0} { + incr i -1 + set p [lindex $::argv $i] + if {$p in [list "-location" "-url" "-repository" "-repos" "-repo"]} { + set j [expr {$i+1}] + if {$j < [llength $::argv]} { + set ::argv [lreplace $::argv $i $j] + } else { + set ::argv [lreplace $::argv $i] + } + } + } + lappend ::argv "-repository" $m +} + +# restart installer with chosen repository +proc restart_with_mir {m} { + # edit original command line by removing any repository parameter + # and adding a repository parameter $m. same for language + replace_repo_parameter $m + replace_lang_parameter + set cmd [linsert $::argv 0 [info nameofexecutable] [info script] "--"] + + # terminate back end + catch {chan close $::inst} + kill_perl + + # restart install-tl with edited command-line + exec {*}$cmd & + exit +} ; # restart_with_mir + +proc continue_with_mir {m} { + replace_repo_parameter $m + set ::mir_selected 1 ; # this will cause select_mirror to finish up +} + +# add $::instroot as local repository if applicable +proc mirror_menu_plus {wnd cmd} { + set have_local 0 + if [file isdirectory [file join $::instroot "archive"]] { + set have_local 1 + } elseif [file readable \ + [file join $::instroot "texmf-dist" "web2c" "texmf.cnf"]] { + set have_local 1 + } + mirror_menu $wnd $cmd + if {[winfo class $wnd] ne "TMenubutton"} { + error_exit "No mirror list found" + } else { + if $have_local { + $wnd.m insert 0 command -label "$::instroot ([__ "Local repository"])" \ + -command "$cmd $::instroot" + } + } + return $wnd +} + +############################################################## + +##### special-purpose uses of main window: select_mirror, splash, log ##### + +proc pre_splash {} { + # build splash window minus buttons + wm withdraw . + + # picture and logo + catch { + image create photo tlimage -file \ + [file join $::instroot "tlpkg" "installer" "texlion.gif"] + pack [frame .white -background white] -side top -fill x -expand 1 + label .image -image tlimage -background white + pack .image -in .white + } + + # wallpaper for remaining widgets + pack [ttk::frame .bg -padding 3] -fill both -expand 1 + + # buttons: abort button, mirrors dropdown menu + pack [ttk::frame .splfb] -in .bg -side bottom -fill x +} + +proc select_mirror {} { + + # buttons: abort button, mirrors dropdown menu, continue + ppack [mirror_menu_plus .splfb.slmir_m continue_with_mir] \ + -side right + ppack [ttk::button .splfb.slmir_a -text [__ "Abort"] -command maybe_abort] \ + -side right + + wm attributes . -topmost + update + wm state . normal + raise . + vwait ::mir_selected +} ; # select_mirror + +proc make_splash {} { + + foreach c [winfo children .splfb] { + catch {destroy $c} + } + update + + ppack [ttk::button .spl_a -text [__ "Abort"] -command maybe_abort] \ + -side right -in .splfb + ppack [mirror_menu_plus .spl_o restart_with_mir] -side right -in .splfb + + # some text + ppack [ttk::label .text -text [__ "TeX Live Installer"] \ + -font bigfont] -in .bg + if {! $::select_repo} { + ppack [ttk::label .loading -text [__ "Trying to load %s. + +If this takes too long, press Abort or choose another repository." \ + $::prelocation]] -in .bg + } + + wm attributes . -topmost + update + wm state . normal + raise . +}; # make_splash + +# ATM ::out_log will be shown only at the end +proc show_log {{do_abort 0}} { + wm withdraw . + foreach c [winfo children .] { + catch {destroy $c} + } + + # wallpaper + pack [ttk::frame .bg -padding 3] -fill both -expand 1 + + # buttons at bottom + pack [ttk::frame .bottom] -in .bg -side bottom -fill x + ttk::button .close -text [__ "Close"] -command exit + ppack .close -in .bottom -side right + if $do_abort { + ttk::button .abort -text [__ "Abort"] -command maybe_abort + ppack .abort -in .bottom -side right + } + bind . { + if {[winfo exists .close] && ! [.close instate disabled]} {.close invoke} + } + + # logs plus their scrollbars + pack [ttk::frame .log] -in .bg -fill both -expand 1 + pack [ttk::scrollbar .log.scroll -command ".log.tx yview"] \ + -side right -fill y + ppack [text .log.tx -height 10 -wrap word -font TkDefaultFont \ + -yscrollcommand ".log.scroll set"] \ + -expand 1 -fill both + .log.tx configure -state normal + .log.tx delete 1.0 end + foreach l $::out_log { + .log.tx insert end "$l\n" + } + if {$::tcl_platform(os) ne "Darwin"} {.log.tx configure -state disabled} + .log.tx yview moveto 1 + + wm resizable . 1 1 + wm overrideredirect . 0 + wm attributes . -topmost + update + wm state . normal + raise . +}; # show_log + +proc log_exit {{mess ""}} { + if {$mess ne ""} {lappend ::out_log $mess} + catch {chan close $::inst} ; # should terminate perl + if {[llength $::out_log] > 0} { + if {[llength $::out_log] < 10} { + tk_messageBox -icon info -message [join $::out_log "\n"] + exit + } else { + show_log ; # its close button exits + } + } else { + exit + } +}; # log_exit + +############################################################# + +########################################################## + +##### installation root ##### + +proc update_full_path {} { + set val [file join \ + [.tltd.prefix_l cget -text] \ + [.tltd.name_l cget -text] \ + [.tltd.rel_l cget -text]] + set val [native_slashify $val] + .tltd.path_l configure -text $val + # ask perl to check path + chan puts $::inst "checkdir" + chan puts $::inst [forward_slashify [.tltd.path_l cget -text]] + chan flush $::inst + if {[read_line_no_eof] eq "0"} { + .tltd.path_l configure -text \ + [__ "Cannot be created or cannot be written to"] \ + -foreground red + .tltd.ok_b state disabled + } else { + .tltd.path_l configure -text $val -foreground $::blk + .tltd.ok_b state !disabled + } + return +} ; # update_full_path + +proc edit_name {} { + create_dlg .tled .tltd + wm title .tled [__ "Directory name..."] + if $::plain_unix {wm attributes .tled -type dialog} + + # wallpaper + pack [ttk::frame .tled.bg -padding 3] -fill both -expand 1 + + # widgets + ttk::label .tled.l -text [__ "Change name (slashes not allowed)"] + pack .tled.l -in .tled.bg -padx 5 -pady 5 + ttk::entry .tled.e -width 20 + .tled.e state !disabled + pack .tled.e -in .tled.bg -pady 5 + .tled.e insert 0 [.tltd.name_l cget -text] + + # now frame with ok and cancel buttons + pack [ttk::frame .tled.buttons] -in .tled.bg -fill x + ttk::button .tled.ok_b -text [__ "Ok"] -command { + if [regexp {[\\/]} [.tled.e get]] { + tk_messageBox -type ok -icon error -message [__ "No slashes allowed"] + } else { + .tltd.name_l configure -text [.tled.e get] + update_full_path + end_dlg "" .tled + } + } + ppack .tled.ok_b -in .tled.buttons -side right -padx 5 -pady 5 + ttk::button .tled.q_b -text [__ "Cancel"] -command {end_dlg "" .tled} + ppack .tled.q_b -in .tled.buttons -side right -padx 5 -pady 5 + bind .tled {.tled.q_b invoke} + + wm protocol .tled WM_DELETE_WINDOW {.tled.q_b invoke} + wm resizable .tled 0 0 + place_dlg .tled .tltd +} ; # edit_name + +proc toggle_rel {} { + if {[.tltd.rel_l cget -text] ne ""} { + set ans \ + [tk_messageBox -message \ + [__ "TL release component highly recommended!\nAre you sure?"] \ + -title [__ "Warning"] \ + -type yesno \ + -default no] + if {$ans eq no} { + return + } + .tltd.rel_l configure -text "" + .tltd.sep1_l configure -text " " + .tltd.rel_b configure -text [__ "Add year"] + } else { + .tltd.rel_l configure -text $::release_year + .tltd.sep1_l configure -text [file separator] + .tltd.rel_b configure -text [__ "Remove year"] + } + update_full_path +} ; # toggle_rel + +proc commit_canonical_local {} { + if {[file tail $::vars(TEXDIR)] eq $::release_year} { + set l [file dirname $::vars(TEXDIR)] + } else { + set l $::vars(TEXDIR) + } + if {[forward_slashify $l] ne \ + [forward_slashify [file dirname $::vars(TEXMFLOCAL)]]} { + set ::vars(TEXMFLOCAL) [forward_slashify [file join $l "texmf-local"]] + } +} + +proc commit_root {} { + set td [.tltd.path_l cget -text] + set ::td_warned 0 + if [is_nonempty $td] { + if {[td_question $td] ne yes} return + } + set ::vars(TEXDIR) [forward_slashify [.tltd.path_l cget -text]] + set ::vars(TEXMFSYSVAR) "$::vars(TEXDIR)/texmf-var" + set ::vars(TEXMFSYSCONFIG) "$::vars(TEXDIR)/texmf-config" + if [winfo exists .tspvl] { + .tspvl configure -text [file join $::vars(TEXDIR) "texmf-dist"] + } + commit_canonical_local + + if {$::vars(instopt_portable)} reset_personal_dirs + destroy .tltd +} + +### main directory dialog ### + +proc texdir_setup {} { + + ### widgets ### + + create_dlg .tltd . + wm title .tltd [__ "Installation root"] + + # wallpaper + pack [ttk::frame .tltd.bg -padding 3] -expand 1 -fill both + + # full path + pack [ttk::label .tltd.path_l -font lfont -anchor center] \ + -in .tltd.bg -pady 10 -fill x -expand 1 + + # installation root components, gridded + pack [ttk::frame .tltd.fr1 -borderwidth 2 -relief groove] \ + -in .tltd.bg -fill x -expand 1 + grid columnconfigure .tltd.fr1 0 -weight 1 + grid columnconfigure .tltd.fr1 2 -weight 1 + grid columnconfigure .tltd.fr1 4 -weight 1 + set rw -1 + # path components, as labels + incr rw + pgrid [ttk::label .tltd.prefix_l] -in .tltd.fr1 -row $rw -column 0 + pgrid [ttk::label .tltd.sep0_l -text "/"] \ + -in .tltd.fr1 -row $rw -column 1 + pgrid [ttk::label .tltd.name_l] -in .tltd.fr1 -row $rw -column 2 + pgrid [ttk::label .tltd.sep1_l -text "/"] \ + -in .tltd.fr1 -row $rw -column 3 + pgrid [ttk::label .tltd.rel_l -width 6] \ + -in .tltd.fr1 -row $rw -column 4 + # corresponding buttons + incr rw + pgrid [ttk::button .tltd.prefix_b -text [__ "Browse..."] \ + -command {if [dirbrowser2widget .tltd.prefix_l] update_full_path}] \ + -in .tltd.fr1 -row $rw -column 0 + pgrid [ttk::button .tltd.name_b -text [__ "Change"] -command edit_name] \ + -in .tltd.fr1 -row $rw -column 2 + pgrid [ttk::button .tltd.rel_b -text [__ "Remove year"] \ + -command toggle_rel] \ + -in .tltd.fr1 -row $rw -column 4 + + # windows: note about localized names + if {$::tcl_platform(platform) eq "windows"} { + ttk::label .tltd.loc -anchor w + .tltd.loc configure -text \ + [__ "Localized directory names will be replaced by their real names"] + ppack .tltd.loc -in .tltd.bg -fill x + } + + # ok/cancel buttons + pack [ttk::frame .tltd.frbt] -in .tltd.bg -pady [list 10 0] -fill x + ttk::button .tltd.ok_b -text [__ "Ok"] -command commit_root + ppack .tltd.ok_b -in .tltd.frbt -side right + ttk::button .tltd.cancel_b -text [__ "Cancel"] \ + -command {destroy .tltd} + ppack .tltd.cancel_b -in .tltd.frbt -side right + bind .tltd {.tltd.cancel_b invoke} + + ### initialization and callbacks ### + + set val [native_slashify [file normalize $::vars(TEXDIR)]] + regsub {[\\/]$} $val {} val + + set initdir $val + set name "" + set rel "" + + # TL release subdirectory at the end? + set rel_pat {[\\/](} + append rel_pat $::release_year {)$} + if [regexp $rel_pat $initdir m rel] { + set rel $::release_year + regsub $rel_pat $initdir {} initdir + } + .tltd.rel_l configure -text $rel + + # next-last component + regexp {^(.*)[\\/]([^\\/]*)$} $initdir m initdir name + .tltd.name_l configure -text $name + + # backtrack remaining initdir to something that exists + # and assign it to prefix + set initprev "" + while {! [file isdirectory $initdir]} { + set initprev $initdir + regexp {^(.*)[\\/]([^\\/]*)} $initdir m initdir m1 + if {$initprev eq $initdir} break + } + + if {$initdir eq "" || \ + ($::tcl_platform(platform) eq "windows" && \ + [string index $initdir end] eq ":")} { + append initdir "/" + } + .tltd.prefix_l configure -text $initdir + update_full_path + + bind .tltd commit_root + bind .tltd {destroy .tltd} + + wm protocol .tltd WM_DELETE_WINDOW {.tltd.cancel_b invoke} + wm resizable .tltd 1 0 + place_dlg .tltd +} ; # texdir_setup + +##### other directories: TEXMFLOCAL, TEXMFHOME, portable ##### + +proc edit_dir {d} { + create_dlg .td . + wm title .td $d + if $::plain_unix {wm attributes .td -type dialog} + + # wallpaper + pack [ttk::frame .td.bg -padding 3] -fill both -expand 1 + + if {$d eq "TEXMFHOME"} { + # explain tilde + if {$::tcl_platform(platform) eq "windows"} { + set ev "%USERPROFILE%" + set xpl $::env(USERPROFILE) + } else { + set ev "\$HOME" + set xpl $::env(HOME) + } + ppack [ttk::label .td.tilde \ + -text [__ "'~' equals %s, e.g. %s" $ev $xpl]] \ + -in .td.bg -anchor w + } + + # other widgets + + ppack [ttk::entry .td.e -width 60] -in .td.bg -fill x + .td.e insert 0 [native_slashify $::vars($d)] + + pack [ttk::frame .td.f] -fill x -expand 1 + ttk::button .td.ok -text [__ "Ok"] -command {end_dlg [.td.e get] .td} + ppack .td.ok -in .td.f -side right + ttk::button .td.cancel -text [__ "Cancel"] -command {end_dlg "" .td} + ppack .td.cancel -in .td.f -side right + bind .td {.td.cancel invoke} + + wm protocol .td WM_DELETE_WINDOW {.td.cancel invoke} + wm resizable .td 1 0 + place_dlg .td . + tkwait window .td + if {$::dialog_ans ne ""} { + set ::vars($d) [forward_slashify $::dialog_ans] + if $::vars(instopt_portable) { + if {$d eq "TEXMFLOCAL"} {set ::vars(TEXMFHOME) $::vars($d)} + if {$d eq "TEXMFSYSVAR"} {set ::vars(TEXMFVAR) $::vars($d)} + if {$d eq "TEXMFSYSCONFIG"} {set ::vars(TEXMFCONFIG) $::vars($d)} + update + } + } +} + +proc port_dis_or_activate {toggled} { + if {!$::advanced} return + set yn [yes_no $::vars(instopt_portable)] + .dirportvl configure -text $yn + if {$::vars(instopt_portable)} { + set ::vars(TEXMFHOME) $::vars(TEXMFLOCAL) + set ::vars(TEXMFVAR) $::vars(TEXMFSYSVAR) + set ::vars(TEXMFCONFIG) $::vars(TEXMFSYSCONFIG) + .thomeb state disabled + if $::alltrees { + .tvb state disabled + .tcb state disabled + } + if {$::tcl_platform(platform) eq "windows"} { + # adjust_path + set ::vars(instopt_adjustpath) 0 + .pathb state disabled + .pathl configure -foreground $::gry + # desktop integration + set ::vars(instopt_desktop_integration) 0 + .dkintb state disabled + .dkintl configure -foreground $::gry + # file associations + set ::vars(instopt_file_assocs) 0 + .assocb state disabled + .assocl configure -foreground $::gry + # multi-user + if $::is_admin { + set ::vars(instopt_w32_multi_user) 0 + .adminb state disabled + .adminl configure -foreground $::gry + } + } else { + set ::vars(instopt_adjustpath) 0 + .symspec state disabled + .pathb state disabled + .pathl configure -foreground $::gry + } + } else { + if $toggled { + set ::vars(TEXMFHOME) "~/texmf" + set ::vars(TEXMFVAR) "~/.texlive${::release_year}/texmf-var" + set ::vars(TEXMFCONFIG) "~/.texlive${::release_year}/texmf-config" + } ; # else leave alone + #.tlocb state !disabled + .thomeb state !disabled + if $::alltrees { + #.tsysvb state !disabled + #.tsyscb state !disabled + .tvb state !disabled + .tcb state !disabled + } + if {$::tcl_platform(platform) eq "windows"} { + # adjust_path + set ::vars(instopt_adjustpath) 1 + .pathb state !disabled + .pathl configure -foreground $::blk + # desktop integration + set ::vars(instopt_desktop_integration) 1 + .dkintb state !disabled + .dkintl configure -foreground $::blk + # file associations + set ::vars(instopt_file_assocs) 1 + .assocb state !disabled + .assocl configure -foreground $::blk + # multi-user + if $::is_admin { + set ::vars(instopt_w32_multi_user) 1 + .adminb state !disabled + .adminl configure -foreground $::blk + } + } else { + # set ::vars(instopt_adjustpath) 0 + # leave false, still depends on symlink paths + .symspec state !disabled + if [dis_enable_symlink_option] { + .pathb state !disabled + .pathl configure -foreground $::blk + } + } + } +} + +proc toggle_port {} { + set ::vars(instopt_portable) [expr {!$::vars(instopt_portable)}] + port_dis_or_activate 1 + commit_canonical_local +}; # toggle_port + +############################################################# + +##### selections: binaries, scheme, collections ##### + +proc show_stats {} { + # n. of additional platforms + if [winfo exists .binlm] { + if {$::vars(n_systems_selected) < 2} { + .binlm configure -text [__ "None"] + } else { + .binlm configure -text [expr {$::vars(n_systems_selected) - 1}] + } + } + # n. out of n. packages + if [winfo exists .lcolv] { + .lcolv configure -text \ + [format "%d / %d" \ + $::vars(n_collections_selected) \ + $::vars(n_collections_available)] + } + if [winfo exists .schml] { + .schml configure -text [__ $::scheme_descs($::vars(selected_scheme))] + } + # diskspace: can use -textvariable here + # paper size +}; # show_stats + +############################################################# + +### binaries ### + +# toggle platform in treeview widget, but not in underlying data +proc toggle_bin {b} { + if {$b eq $::vars(this_platform)} { + tk_messageBox -message [__ "Cannot deselect own platform"] + return + } + set m [.tlbin.lst set $b "mk"] + if {$m eq [mark_sym 0]} { + .tlbin.lst set $b "mk" [mark_sym 1] + } else { + .tlbin.lst set $b "mk" [mark_sym 0] + } +}; # toggle_bin + +proc save_bin_selections {} { + set ::vars(n_systems_selected) 0 + foreach b [.tlbin.lst children {}] { + set bb "binary_$b" + if {[.tlbin.lst set $b "mk"] ne [mark_sym 0]} { + incr ::vars(n_systems_selected) + set ::vars($bb) 1 + } else { + set ::vars($bb) 0 + } + if {$b eq "win32"} { + set ::vars(collection-wintools) $::vars($bb) + } + } + update_vars + show_stats +}; # save_bin_selections + +proc sort_bins_by_value {n m} { + return [string compare [__ $::bin_descs($n)] [__ $::bin_descs($m)]] +} + +proc select_binaries {} { + create_dlg .tlbin . + wm title .tlbin [__ "Binaries"] + + # wallpaper + pack [ttk::frame .tlbin.bg -padding 3] -expand 1 -fill both + + # ok, cancel buttons + pack [ttk::frame .tlbin.buts] -in .tlbin.bg -side bottom -fill x + ttk::button .tlbin.ok -text [__ "Ok"] -command \ + {save_bin_selections; update_vars; end_dlg 1 .tlbin} + ppack .tlbin.ok -in .tlbin.buts -side right + ttk::button .tlbin.cancel -text [__ "Cancel"] -command {end_dlg 0 .tlbin} + 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 + + ttk::treeview .tlbin.lst -columns {mk desc} -show {} \ + -selectmode extended -yscrollcommand {.tlbin.binsc set} + + ttk::scrollbar .tlbin.binsc -orient vertical -command {.tlbin.lst yview} + .tlbin.lst column mk -stretch 0 -width [expr {$::cw * 3}] + .tlbin.lst column desc -stretch 1 + foreach b [lsort -command sort_bins_by_value [array names ::bin_descs]] { + set bb "binary_$b" + .tlbin.lst insert {} end -id $b -values \ + [list [mark_sym $::vars($bb)] [__ $::bin_descs($b)]] + } + pgrid .tlbin.lst -in .tlbin.binsf -row 0 -column 0 -sticky news + pgrid .tlbin.binsc -in .tlbin.binsf -row 0 -column 1 -sticky ns + grid columnconfigure .tlbin.binsf 0 -weight 1 + grid rowconfigure .tlbin.binsf 0 -weight 1 + bind .tlbin.lst {toggle_bin [.tlbin.lst focus]} + bind .tlbin.lst {toggle_bin [.tlbin.lst focus]} + bind .tlbin.lst \ + {toggle_bin [.tlbin.lst identify item %x %y]} + + wm protocol .tlbin WM_DELETE_WINDOW {.tlbin.cancel invoke} + wm resizable .tlbin 1 1 + place_dlg .tlbin . +}; # select_binaries + +############################################################# + +### scheme ### + +proc select_scheme {} { + create_dlg .tlschm . + wm title .tlschm [__ "Schemes"] + + # wallpaper + pack [ttk::frame .tlschm.bg -padding 3] -fill both -expand 1 + + # buttons at bottom + pack [ttk::frame .tlschm.buts] -in .tlschm.bg -side bottom -fill x + ttk::button .tlschm.ok -text [__ "Ok"] -command { + # tree selection is a list: + set ::vars(selected_scheme) [lindex [.tlschm.lst selection] 0] + foreach v [array names ::vars] { + if {[string range $v 0 6] eq "scheme-"} { + if {$v eq $::vars(selected_scheme)} { + set ::vars($v) 1 + } else { + set ::vars($v) 0 + } + } + } + update_vars + show_stats + end_dlg 1 .tlschm + } + ppack .tlschm.ok -in .tlschm.buts -side right + ttk::button .tlschm.cancel -text [__ "Cancel"] -command {end_dlg 0 .tlschm} + ppack .tlschm.cancel -in .tlschm.buts -side right + 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 + ppack .tlschm.lst -in .tlschm.bg -fill both -expand 1 + foreach s $::schemes_order { + .tlschm.lst insert {} end -id $s -values [list [__ $::scheme_descs($s)]] + } + # we already made sure that $::vars(selected_scheme) has a valid value + .tlschm.lst selection set [list $::vars(selected_scheme)] + + wm protocol .tlschm WM_DELETE_WINDOW {tlschm.cancel invoke} + wm resizable .tlschm 1 0 + place_dlg .tlschm . +}; # select_scheme + +############################################################# + +### collections ### + +# toggle collection in treeview widget, but not in underlying data +proc toggle_coll {cs c} { + # cs: treeview widget; c: selected child item + set m [$cs set $c "mk"] + if {$m eq [mark_sym 0]} { + $cs set $c "mk" [mark_sym 1] + } else { + $cs set $c "mk" [mark_sym 0] + } +}; # toggle_coll + +proc save_coll_selections {} { + foreach wgt {.tlcoll.other .tlcoll.lang} { + foreach c [$wgt children {}] { + if {[$wgt set $c "mk"] eq [mark_sym 0]} { + set ::vars($c) 0 + } else { + set ::vars($c) 1 + } + } + } + set ::vars(selected_scheme) "scheme-custom" + update_vars + show_stats +}; # save_coll_selections + +proc sort_colls_by_value {n m} { + return [string compare [__ $::coll_descs($n)] [__ $::coll_descs($m)]] +} + +proc select_collections {} { + # 2018: more than 40 collections + # The tcl installer acquires collections from install-menu-extl.pl, + # but install-tl also has an array of collections. + # Use treeview for checkbox column and display of + # collection descriptions rather than names. + # buttons: select all, select none, ok, cancel + # should some collections be excluded? Check install-menu-* code. + create_dlg .tlcoll . + wm title .tlcoll [__ "Collections"] + + # wallpaper + pack [ttk::frame .tlcoll.bg -padding 3] -fill both -expand 1 + + # frame at bottom with ok and cancel buttons + pack [ttk::frame .tlcoll.butf] -in .tlcoll.bg -side bottom -fill x + ttk::button .tlcoll.ok -text [__ "Ok"] -command \ + {save_coll_selections; end_dlg 1 .tlcoll} + ppack .tlcoll.ok -in .tlcoll.butf -side right + ttk::button .tlcoll.cancel -text [__ "Cancel"] -command {end_dlg 0 .tlcoll} + ppack .tlcoll.cancel -in .tlcoll.butf -side right + bind .tlcoll {.tlcoll.cancel invoke} + + # Treeview and scrollbar for non-language- and language collections resp. + pack [ttk::frame .tlcoll.both] -in .tlcoll.bg -expand 1 -fill both + + foreach t {"lang" "other"} { + + # frames with select all/none buttons, separately for lang and others + set wgb .tlcoll.b$t + ttk::frame $wgb + ttk::label ${wgb}sel -text [__ "Select"] + ttk::button ${wgb}all -text [__ "All"] -padding 1 -command \ + "foreach c \[.tlcoll.$t children {}\] \{ + .tlcoll.$t set \$c mk \[mark_sym 1\]\}" + ttk::button ${wgb}none -text [__ "None"] -padding 1 -command \ + "foreach c \[.tlcoll.$t children {}\] \{ + .tlcoll.$t set \$c mk \[mark_sym 0\]\}" + pack ${wgb}sel ${wgb}all ${wgb}none -in $wgb \ + -side left -padx 3 -pady 3 + + # trees with collections and markers, lang and other separately + set wgt ".tlcoll.$t" + ttk::treeview $wgt -columns {mk desc} -show {headings} \ + -selectmode extended -yscrollcommand "${wgt}sc set" + $wgt heading "mk" -text "" + if {$t eq "lang"} { + $wgt heading "desc" -text [__ "Languages"] + } else { + $wgt heading "desc" -text [__ "Other collections"] + } + # and their vertical scrollbars + ttk::scrollbar ${wgt}sc -orient vertical -command "$wgt yview" + $wgt column mk -width [expr {$::cw * 3}] -stretch 0 + $wgt column desc -stretch 1 + + bind $wgt {toggle_coll %W [%W focus]} + bind $wgt {toggle_coll %W [%W focus]} + bind $wgt {toggle_coll %W [%W identify item %x %y]} + } + grid .tlcoll.blang x .tlcoll.bother -in .tlcoll.both -sticky w + grid .tlcoll.lang .tlcoll.langsc .tlcoll.other .tlcoll.othersc \ + -in .tlcoll.both + grid columnconfigure .tlcoll.both 0 -weight 1 + grid columnconfigure .tlcoll.both 1 -weight 0 + grid columnconfigure .tlcoll.both 2 -weight 2 + grid columnconfigure .tlcoll.both 3 -weight 0 + grid configure .tlcoll.lang .tlcoll.other .tlcoll.langsc .tlcoll.othersc \ + -sticky nsew + grid rowconfigure .tlcoll.both 1 -weight 1 + + + foreach c [lsort -command sort_colls_by_value [array names ::coll_descs]] { + if [string equal -length 15 "collection-lang" $c] { + set wgt ".tlcoll.lang" + } else { + set wgt ".tlcoll.other" + } + $wgt insert {} end -id $c -values \ + [list [mark_sym $::vars($c)] [__ $::coll_descs($c)]] + } + + wm protocol .tlcoll WM_DELETE_WINDOW {.tlcoll.cancel invoke} + wm resizable .tlcoll 1 1 + place_dlg .tlcoll . +}; # select_collections + +################################################## + +# option handling + +# for multi-value options: +# below, $c is a combobox with values $l. The index of the current value in $l +# corresponds to the value of $::vars($v). + +proc var2combo {v c} { + $c current $::vars($v) +} +proc combo2var {c v} { + set ::vars($v) [$c current] +} +# if the variable has an impact on what to install: +proc combo2var_calc {c v} { + combo2var c v + update_vars + show_stats +} + +##### desktop integration; platform-specific ##### + +if {$::tcl_platform(platform) ne "windows"} { + + ### symlinks into standard directories ### + + # 'file writable' is only a check of unix permissions + proc dest_ok {d} { + if {$d eq ""} {return 0} + set its 1 + while 1 { + if [file exists $d] { + if {! [file isdirectory $d]} { + return 0 + } elseif {! [file writable $d]} { + return 0 + } else { + return 1 + } + } ; # if file exists + # try a level up + set d [file dirname $d] + set its [expr {$its + 1}] + if {$its > 3} {return 0} + } + return 0 + } + + proc dis_enable_symlink_option {} { + set ok 1 + foreach v {"bin" "man" "info"} { + set vv "tlpdbopt_sys_$v" + if {! [info exists ::vars($vv)]} {set ok 0; break} + set d $::vars($vv) + if {![dest_ok $d]} {set ok 0; break} + } + if {$ok && !$::vars(instopt_portable)} { + .pathb state !disabled + .pathl configure -foreground $::blk + } else { + set ok 0 + .pathb state disabled + .pathl configure -foreground $::gry + set ::vars(instopt_adjustpath) 0 + } + return $ok + } + + # check validity of all three proposed symlink target directories. + # do not dis/enable .pathb until return from .edsyms dialog. + proc check_sym_entries {} { + set ok 1 + foreach v {"bin" "man" "info"} { + if [dest_ok [.edsyms.${v}e get]] { + .edsyms.${v}mk configure -text "\u2714" -foreground $::blk + } else { + .edsyms.${v}mk configure -text "\u2718" -foreground red + set ok 0 + } + } + if $ok { + .edsyms.warn configure -text "" + } else { + .edsyms.warn configure -text \ + [__ "Warning. Not all configured directories are writable!"] + } + } + + proc commit_sym_entries {} { + foreach v {"bin" "man" "info"} { + set vv "tlpdbopt_sys_$v" + set ::vars($vv) [.edsyms.${v}e get] + if {[string index $::vars($vv) 0] eq "~"} { + set ::vars($vv) "$::env(HOME)[string range $::vars($vv) 1 end]" + } + } + if [dis_enable_symlink_option] { + set ::vars(instopt_adjustpath) 1 + } + } + + proc edit_symlinks {} { + + create_dlg .edsyms . + wm title .edsyms [__ "Symlinks"] + + pack [ttk::frame .edsyms.bg -padding 3] -expand 1 -fill both + set rw -1 + + pack [ttk::frame .edsyms.fr0] -in .edsyms.bg -expand 1 -fill both + foreach v {"bin" "man" "info"} { + incr rw + # description + pgrid [ttk::label .edsyms.${v}l -text ""] \ + -in .edsyms.fr0 -row $rw -column 0 -sticky e + # ok mark + pgrid [ttk::label .edsyms.${v}mk -text ""] \ + -in .edsyms.fr0 -row $rw -column 1 + # entry widget + pgrid [ttk::entry .edsyms.${v}e -width 40] \ + -in .edsyms.fr0 -row $rw -column 2 + set vv "tlpdbopt_sys_$v" + if [info exists ::vars($vv)] { + .edsyms.${v}e insert 0 $::vars($vv) + }; # else leave empty + bind .edsyms.${v}e {+check_sym_entries} + # browse button + pgrid [ttk::button .edsyms.${v}br -text [__ "Browse..."] -command \ + "dirbrowser2widget .edsyms.${v}e; check_sym_entries"] \ + -in .edsyms.fr0 -row $rw -column 3 + } + .edsyms.binl configure -text [__ "Binaries"] + .edsyms.manl configure -text [__ "Man pages"] + .edsyms.infol configure -text [__ "Info pages"] + + # warning about read-only target directories + incr rw + pgrid [ttk::label .edsyms.warn -foreground red] \ + -in .edsyms.fr0 -column 2 -columnspan 2 -sticky w + + grid columnconfigure .edsyms.fr0 0 -weight 0 + grid columnconfigure .edsyms.fr0 1 -weight 0 + grid columnconfigure .edsyms.fr0 2 -weight 1 + grid columnconfigure .edsyms.fr0 3 -weight 0 + + # ok, cancel + pack [ttk::frame .edsyms.fr1] -expand 1 -fill both + ppack [ttk::button .edsyms.ok -text [__ "Ok"] -command { + commit_sym_entries; end_dlg 1 .edsyms}] -in .edsyms.fr1 -side right + ppack [ttk::button .edsyms.cancel -text [__ "Cancel"] -command { + end_dlg 0 .edsyms}] -in .edsyms.fr1 -side right + bind .edsyms {.edsyms.cancel invoke} + + check_sym_entries + + wm protocol .edsyms WM_DELETE_WINDOW {.edsyms.cancel invoke} + wm resizable .edsyms 1 0 + place_dlg .edsyms . + } ; # edit_symlinks +} ; # $::tcl_platform(platform) ne "windows" + +############################################################# + +# 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. +# We still use blocking i/o: frontend and backend wait for each other. + +# idea: follow submenu organization of text installer +# for 3-way options, create an extra level of children +# instead of wizard install, supppress some options + +proc run_menu {} { + if [info exists ::env(dbgui)] { + #puts "\ndbgui: run_menu: advanced is now $::advanced" + #puts "dbgui: run_menu: alltrees is now $::alltrees" + } + wm withdraw . + foreach c [winfo children .] { + catch {destroy $c} + } + + # wallpaper + pack [ttk::frame .bg -padding 3] -fill both -expand 1 + + # title + ttk::label .title -text [__ "TeX Live %s Installer" $::release_year] \ + -font titlefont + pack .title -pady {10 1} -in .bg + pack [ttk::label .svn -text "r. $::svn"] -in .bg + + pack [ttk::separator .seph0 -orient horizontal] \ + -in .bg -pady 3 -fill x + + # frame at bottom with install/quit buttons + pack [ttk::frame .final] \ + -in .bg -side bottom -pady [list 5 2] -fill x + ppack [ttk::button .install -text [__ "Install"] -command { + set ::menu_ans "startinst"}] -in .final -side right + ppack [ttk::button .quit -text [__ "Quit"] -command { + set ::out_log {} + set ::menu_ans "no_inst"}] -in .final -side right + bind . whataboutclose + if {!$::advanced} { + ppack [ttk::button .adv -text [__ "Advanced"] -command { + set ::menu_ans "advanced" + #if [info exists ::env(dbgui)] {puts "dbgui: requested advanced"} + }] -in .final -side left + } + pack [ttk::separator .seph1 -orient horizontal] \ + -in .bg -side bottom -pady 3 -fill x + + # directories, selections + # advanced and basic have different frame setups + if $::advanced { + pack [ttk::frame .left] -in .bg -side left -fill both -expand 1 + set curf .left + } else { + pack [ttk::frame .main] -in .bg -side top -fill both -expand 1 + set curf .main + } + + # directory section + pack [ttk::frame .dirf] -in $curf -fill x + grid columnconfigure .dirf 1 -weight 1 + set rw -1 + + if $::advanced { + incr rw + # labelframes do not look quite right on macos, + # instead, separate label widget for title + pgrid [ttk::label .dirftitle -text [__ "Installation root"] \ + -font hfont] \ + -in .dirf -row $rw -column 0 -columnspan 3 -sticky w + .dirftitle configure -text [__ "Directories"] + } + + incr rw + pgrid [ttk::label .tdirll] -in .dirf -row $rw -column 0 -sticky nw + set s [__ "Installation root"] + if $::advanced { + .tdirll configure -text "TEXDIR:\n$s" + } else { + .tdirll configure -text $s + } + pgrid [ttk::label .tdirvl -textvariable ::vars(TEXDIR)] \ + -in .dirf -row $rw -column 1 -sticky nw + pgrid [ttk::button .tdirb -text [__ "Change"] -command texdir_setup] \ + -in .dirf -row $rw -column 2 -sticky new + + if $::advanced { + if $::alltrees { + incr rw + pgrid [ttk::label .tspll -text [__ "Main tree"]] \ + -in .dirf -row $rw -column 0 -sticky nw + pgrid [ttk::label .tspvl] -in .dirf -row $rw -column 1 -sticky nw + .tspvl configure -text [file join $::vars(TEXDIR) "texmf-dist"] + + incr rw + pgrid [ttk::label .tsysvll -text "TEXMFSYSVAR"] \ + -in .dirf -row $rw -column 0 -sticky nw + pgrid [ttk::label .tsysvvl -textvariable ::vars(TEXMFSYSVAR)] \ + -in .dirf -row $rw -column 1 -sticky nw + ttk::button .tsysvb -text [__ "Change"] -command {edit_dir "TEXMFSYSVAR"} + pgrid .tsysvb -in .dirf -row $rw -column 2 -sticky new + + incr rw + pgrid [ttk::label .tsyscll -text "TEXMFSYSCONFIG"] \ + -in .dirf -row $rw -column 0 -sticky nw + pgrid [ttk::label .tsyscvl -textvariable ::vars(TEXMFSYSCONFIG)] \ + -in .dirf -row $rw -column 1 -sticky nw + ttk::button .tsyscb -text [__ "Change"] \ + -command {edit_dir "TEXMFSYSCONFIG"} + pgrid .tsyscb -in .dirf -row $rw -column 2 -sticky new + } + incr rw + set s [__ "Local additions"] + pgrid [ttk::label .tlocll -text "TEXMFLOCAL:\n$s"] \ + -in .dirf -row $rw -column 0 -sticky nw + pgrid [ttk::label .tlocvl -textvariable ::vars(TEXMFLOCAL)] \ + -in .dirf -row $rw -column 1 -sticky nw + ttk::button .tlocb -text [__ "Change"] -command {edit_dir "TEXMFLOCAL"} + pgrid .tlocb -in .dirf -row $rw -column 2 -sticky new + + incr rw + set s [__ "Per-user additions"] + pgrid [ttk::label .thomell -text "TEXMFHOME:\n$s"] \ + -in .dirf -row $rw -column 0 -sticky nw + pgrid [ttk::label .thomevl -textvariable ::vars(TEXMFHOME)] \ + -in .dirf -row $rw -column 1 -sticky nw + ttk::button .thomeb -text [__ "Change"] -command {edit_dir "TEXMFHOME"} + pgrid .thomeb -in .dirf -row $rw -column 2 -sticky ne + if $::alltrees { + incr rw + pgrid [ttk::label .tvll -text "TEXMFVAR"] \ + -in .dirf -row $rw -column 0 -sticky nw + pgrid [ttk::label .tvvl -textvariable ::vars(TEXMFVAR)] \ + -in .dirf -row $rw -column 1 -sticky nw + ttk::button .tvb -text [__ "Change"] -command {edit_dir "TEXMFVAR"} + pgrid .tvb -in .dirf -row $rw -column 2 -sticky new + incr rw + pgrid [ttk::label .tcll -text "TEXMFCONFIG"] \ + -in .dirf -row $rw -column 0 -sticky nw + pgrid [ttk::label .tcvl -textvariable ::vars(TEXMFCONFIG)] \ + -in .dirf -row $rw -column 1 -sticky nw + ttk::button .tcb -text [__ "Change"] \ + -command {edit_dir "TEXMFCONFIG"} + pgrid .tcb -in .dirf -row $rw -column 2 -sticky new + } + + incr rw + if {!$::alltrees} { + ttk::button .tmoreb -text [__ "More ..."] -command { + set ::menu_ans "alltrees" + #if [info exists ::env(dbgui)] {puts "dbgui: requested alltrees"} + } + pgrid .tmoreb -in .dirf -row $rw -column 2 -sticky ne + } + + incr rw + pgrid [ttk::label .dirportll \ + -text [__ "Portable setup:\nMay reset TEXMFLOCAL\nand TEXMFHOME"]] \ + -in .dirf -row $rw -column 0 -sticky nw + pgrid [ttk::label .dirportvl] -in .dirf -row $rw -column 1 -sticky nw + pgrid [ttk::button .tportb -text [__ "Toggle"] -command toggle_port] \ + -in .dirf -row $rw -column 2 -sticky ne + .dirportvl configure -text [yes_no $::vars(instopt_portable)] + + # platforms section + if {$::tcl_platform(platform) ne "windows"} { + pack [ttk::frame .platf] -in .left -fill x + grid columnconfigure .platf 1 -weight 1 + set rw -1 + + incr rw + pgrid [ttk::label .binftitle -text [__ "Platforms"] -font hfont] \ + -in .platf -row $rw -column 0 -columnspan 3 -sticky w + + # current platform + incr rw + ttk::label .binl0 \ + -text [__ "Current platform:"] + pgrid .binl0 -in .platf -row $rw -column 0 -sticky w + ttk::label .binl1 \ + -text [__ "$::bin_descs($::vars(this_platform))"] + pgrid .binl1 -in .platf -row $rw -column 1 -sticky w + # additional platforms + incr rw + pgrid [ttk::label .binll -text [__ "N. of additional platform(s):"]] \ + -in .platf -row $rw -column 0 -sticky w + pgrid [ttk::label .binlm] -in .platf -row $rw -column 1 -sticky w + pgrid [ttk::button .binb -text [__ "Change"] -command select_binaries] \ + -in .platf -row $rw -column 2 -sticky e + } + + # Selections section + pack [ttk::frame .selsf] -in .left -fill x + grid columnconfigure .selsf 1 -weight 1 + set rw -1 + + incr rw + pgrid [ttk::label .selftitle -text [__ "Selections"] -font hfont] \ + -in .selsf -row $rw -column 0 -columnspan 3 -sticky w + + # schemes + incr rw + pgrid [ttk::label .schmll -text [__ "Scheme:"]] \ + -in .selsf -row $rw -column 0 -sticky w + pgrid [ttk::label .schml -text ""] \ + -in .selsf -row $rw -column 1 -sticky w + pgrid [ttk::button .schmb -text [__ "Change"] -command select_scheme] \ + -in .selsf -row $rw -column 2 -sticky e + + # collections + incr rw + pgrid [ttk::label .lcoll -text [__ "N. of collections:"]] \ + -in .selsf -row $rw -column 0 -sticky w + pgrid [ttk::label .lcolv] -in .selsf -row $rw -column 1 -sticky w + pgrid [ttk::button .collb -text [__ "Customize"] \ + -command select_collections] \ + -in .selsf -row $rw -column 2 -sticky e + } + + # total size + # curf: current frame + set curf [expr {$::advanced ? ".selsf" : ".dirf"}] + incr rw + ttk::label .lsize -text [__ "Disk space required (in MB):"] + ttk::label .size_req -textvariable ::vars(total_size) + pgrid .lsize -in $curf -row $rw -column 0 -sticky w + pgrid .size_req -in $curf -row $rw -column 1 -sticky w + + ######################################################## + # right side: options + # 3 columns. Column 1 can be merged with either 0 or 2. + + if $::advanced { + + pack [ttk::separator .sepv -orient vertical] \ + -in .bg -side left -padx 3 -fill y + pack [ttk::frame .options] -in .bg -side right -fill both -expand 1 + + set curf .options + grid columnconfigure .options 0 -weight 1 + set rw -1 + + incr rw + pgrid [ttk::label .optitle -text [__ "Options"] -font hfont] \ + -in $curf -row $rw -column 0 -columnspan 3 -sticky w + } else { + set curf .dirf + } + + # instopt_letter + set ::lpapers [list "A4" "letter"] + incr rw + pgrid [ttk::label .paperl -text [__ "Default paper size"]] \ + -in $curf -row $rw -column 0 -sticky w + pgrid [ttk::combobox .paperb -values $::lpapers -state readonly -width 8] \ + -in $curf -row $rw -column 1 -columnspan 2 -sticky e + var2combo "instopt_letter" .paperb + bind .paperb <> {+combo2var .paperb "instopt_letter"} + + if $::advanced { + # instopt_write18_restricted + incr rw + pgrid [ttk::label .write18l -text \ + [__ "Allow execution of restricted list of programs via \\write18"]] \ + -in $curf -row $rw -column 0 -columnspan 2 -sticky w + ttk::checkbutton .write18b -variable ::vars(instopt_write18_restricted) + pgrid .write18b -in $curf -row $rw -column 2 -sticky e + + # tlpdbopt_create_formats + incr rw + pgrid [ttk::label .formatsl -text [__ "Create all format files"]] \ + -in $curf -row $rw -column 0 -columnspan 2 -sticky w + ttk::checkbutton .formatsb -variable ::vars(tlpdbopt_create_formats) + pgrid .formatsb -in $curf -row $rw -column 2 -sticky e + + # tlpdbopt_install_docfiles + if $::vars(doc_splitting_supported) { + incr rw + pgrid [ttk::label .docl -text [__ "Install font/macro doc tree"]] \ + -in $curf -row $rw -column 0 -columnspan 2 -sticky w + ttk::checkbutton .docb -variable ::vars(tlpdbopt_install_docfiles) \ + -command {update_vars; show_stats} + pgrid .docb -in $curf -row $rw -column 2 -sticky e + } + + # tlpdbopt_install_srcfiles + if $::vars(src_splitting_supported) { + incr rw + pgrid [ttk::label .srcl -text [__ "Install font/macro source tree"]] \ + -in $curf -row $rw -column 0 -columnspan 2 -sticky w + ttk::checkbutton .srcb -variable ::vars(tlpdbopt_install_srcfiles) \ + -command {update_vars; show_stats} + pgrid .srcb -in $curf -row $rw -column 2 -sticky e + } + } + + if {$::tcl_platform(platform) eq "windows"} { + + if $::advanced { + # instopt_adjustpath + incr rw + pgrid [ttk::label .pathl -text [__ "Adjust searchpath"]] \ + -in $curf -row $rw -column 0 -columnspan 2 -sticky w + ttk::checkbutton .pathb -variable ::vars(instopt_adjustpath) + pgrid .pathb -in $curf -row $rw -column 2 -sticky e + + # tlpdbopt_desktop_integration + set ::desk_int \ + [list [__ "No shortcuts"] [__ "TeX Live menu"] [__ "Launcher entry"]] + incr rw + pgrid [ttk::label .dkintl -text [__ "Desktop integration"]] \ + -in $curf -row $rw -column 0 -sticky w + pgrid [ttk::combobox .dkintb -values $::desk_int -state readonly \ + -width 20] \ + -in $curf -row $rw -column 1 -columnspan 2 -sticky e + var2combo "tlpdbopt_desktop_integration" .dkintb + bind .dkintb <> \ + {+combo2var .dkintb "tlpdbopt_desktop_integration"} + + # tlpdbopt_file_assocs + set ::assoc [list [__ "None"] [__ "Only new"] [__ "All"]] + incr rw + pgrid [ttk::label .assocl -text [__ "File associations"]] \ + -in $curf -row $rw -column 0 -sticky w + pgrid [ttk::combobox .assocb -values $::assoc -state readonly -width 12] \ + -in $curf -row $rw -column 1 -columnspan 2 -sticky e + var2combo "tlpdbopt_file_assocs" .assocb + bind .assocb <> \ + {+combo2var .assocb "tlpdbopt_file_assocs"} + } + + # tlpdbopt_w32_multi_user + incr rw + pgrid [ttk::label .adminl -text [__ "Install for all users"]] \ + -in $curf -row $rw -column 0 -columnspan 2 -sticky w + ttk::checkbutton .adminb -variable ::vars(tlpdbopt_w32_multi_user) + pgrid .adminb -in $curf -row $rw -column 2 -sticky e + if {!$::is_admin} { + .adminb state disabled + .adminl configure -foreground $::gry + } + + # collection-texworks + incr rw + pgrid [ttk::label .texwl -text [__ "Install TeXworks front end"]] \ + -in $curf -row $rw -column 0 -columnspan 2 -sticky w + ttk::checkbutton .texwb -variable ::vars(collection-texworks) + pgrid .texwb -in $curf -row $rw -column 2 -sticky e + bind .texwb {+ + set ::vars(selected_scheme) "scheme-custom"; update_vars; show_stats} + bind .texwb {+ + set ::vars(selected_scheme) "scheme-custom"; update_vars; show_stats} + bind .texwb {+ + set ::vars(selected_scheme) "scheme-custom"; update_vars; show_stats} + + } else { + if $::advanced { + # instopt_adjustpath, unix edition: symlinks + # tlpdbopt_sys_[bin|info|man] + incr rw + pgrid [ttk::label .pathl \ + -text [__ "Create symlinks in standard directories"]] \ + -in $curf -row $rw -column 0 -columnspan 2 -sticky w + pgrid [ttk::checkbutton .pathb -variable ::vars(instopt_adjustpath)] \ + -in $curf -row $rw -column 2 -sticky e + dis_enable_symlink_option; # enable only if standard directories ok + incr rw + pgrid [ttk::button .symspec -text [__ "Specify directories"] \ + -command edit_symlinks] \ + -in $curf -row $rw -column 1 -columnspan 2 -sticky e + } + } + + if $::advanced { + # spacer/filler + incr rw + pgrid [ttk::label .spaces -text " "] -in $curf -row $rw -column 0 + grid rowconfigure $curf $rw -weight 1 + # final entry: instopt_adjustrepo + incr rw + pgrid [ttk::label .ctanl -text \ + [__ "After install, set CTAN as source for package updates"]] \ + -in $curf -row $rw -column 0 -columnspan 2 -sticky w + pgrid [ttk::checkbutton .ctanb -variable ::vars(instopt_adjustrepo)] \ + -in $curf -row $rw -column 2 -sticky e + } + + if $::advanced {port_dis_or_activate 0} + show_stats + wm overrideredirect . 0 + wm attributes . -topmost + wm resizable . 0 0 + update + wm state . normal + raise . + if {[is_nonempty $::vars(TEXDIR)] && ! $::td_warned} { + td_warn $::vars(TEXDIR) + } + #if [info exists ::env(dbgui)] {puts "dbgui: unsetting menu_ans"} + unset -nocomplain ::menu_ans + vwait ::menu_ans + #if [info exists ::env(dbgui)] {puts "dbgui0: menu_ans is $::menu_ans"} + return $::menu_ans +}; # run_menu + +############################################################# + +# we need data from the backend. +# choices of schemes, platforms and options impact choices of +# collections and required disk space. +# the vars array contains all this variable information. +# the calc_depends proc communicates with the backend to update this array. + +proc read_descs {} { + set l [read_line_no_eof] + if {$l ne "descs"} { + err_exit "'descs' expected but $l found" + } + while 1 { + set l [read_line_no_eof] + if [regexp {^([^:]+): (\S+) (.*)$} $l m p c d] { + if {$c eq "Collection"} { + set ::coll_descs($p) $d + } elseif {$c eq "Scheme"} { + set ::scheme_descs($p) $d + } + } elseif {$l eq "enddescs"} { + break + } else { + err_exit "Illegal line $l in descs section" + } + } + set ::scheme_descs(scheme-custom) [__ "Custom scheme"] +} + +proc read_vars {} { + set l [read_line_no_eof] + if {$l ne "vars"} { + err_exit "'vars' expected but $l found" + } + while 1 { + set l [read_line_no_eof] + if [regexp {^([^:]+): (.*)$} $l m k v] { + set ::vars($k) $v + } elseif {$l eq "endvars"} { + break + } else { + err_exit "Illegal line $l in vars section" + } + } + if {"total_size" ni [array names ::vars]} { + set ::vars(total_size) 0 + } +}; # read_vars + +proc write_vars {} { + chan puts $::inst "vars" + foreach v [array names ::vars] {chan puts $::inst "$v: $::vars($v)"} + chan puts $::inst "endvars" + chan flush $::inst +} + +proc update_vars {} { + chan puts $::inst "calc" + write_vars + read_vars +} + +proc read_menu_data {} { + # the expected order is: year, svn, descs, vars, schemes (one line), binaries + # note. lindex returns an empty string if the index argument is too high. + # empty lines result in an err_exit. + + # year; should be first line + set l [read_line_no_eof] + if [regexp {^year: (\S+)$} $l d y] { + set ::release_year $y + } else { + err_exit "year expected but $l found" + } + + # revision; should be second line + set l [read_line_no_eof] + if [regexp {^svn: (\S+)$} $l d y] { + set ::svn $y + } else { + err_exit "revision expected but $l found" + } + + # windows: admin status + if {$::tcl_platform(platform) eq "windows"} { + set l [read_line_no_eof] + if [regexp {^admin: ([01])$} $l d a] { + set ::is_admin $a + } else { + err_exit "admin: \[0|1\] expected but $l found" + } + } + + read_descs + + read_vars + + # schemes order (one line) + set l [read_line_no_eof] + if [regexp {^schemes_order: (.*)$} $l m sl] { + set ::schemes_order $sl + } else { + err_exit "schemes_order expected but $l found" + } + if {"selected_scheme" ni [array names ::vars] || \ + $::vars(selected_scheme) ni $::schemes_order} { + set ::vars(selected_scheme) [lindex $::schemes_order 0] + } + + # binaries + set l [read_line_no_eof] + if {$l ne "binaries"} { + err_exit "'binaries' expected but $l found" + } + while 1 { + set l [read_line_no_eof] + if [regexp {^([^:]+): (.*)$} $l m k v] { + set ::bin_descs($k) $v + } elseif {$l eq "endbinaries"} { + break + } else { + err_exit "Illegal line $l in binaries section" + } + } + + set l [read_line_no_eof] + if {$l ne "endmenudata"} { + err_exit "'endmenudata' expected but $l found" + } +}; # read_menu_data + +proc answer_to_perl {} { + # we just got a line "mess_yesno" from perl + # finish reading the message text, put it in a message box + # and write back the answer + set mess {} + while 1 { + set ll [read_line] + if {[lindex $ll 0] < 0} { + err_exit "Error while reading from Perl backend" + } else { + set l [lindex $ll 1] + } + if {$l eq "endmess"} { + break + } else { + lappend mess $l + } + } + set m [join $mess "\n"] + set ans [tk_messageBox -type yesno -icon question -message $m] + chan puts $::inst [expr {$ans eq yes ? "y" : "n"}] + chan flush $::inst +}; # answer_to_perl + +proc run_installer {} { + set ::out_log {} + show_log 1; # 1: with abort button + .close state disabled + if $::did_gui { + chan puts $::inst "startinst" + write_vars + } + # the backend was already running and needs no further encouragement + + # switch to non-blocking i/o + chan configure $::inst -buffering line -blocking 0 + chan event $::inst readable read_line_cb +}; # run_installer + +proc whataboutclose {} { + if [winfo exists .abort] { + # log window with abort + .abort invoke + } elseif [winfo exists .log] { + # log window without abort + .close invoke + } elseif [winfo exists .quit] { + # menu window + .quit invoke + } + # no action for close button of splash screen +} + +proc main_prog {} { + + wm title . [__ "TeX Live Installer"] + wm protocol . WM_DELETE_WINDOW whataboutclose + + if {[file exists $::dblfile]} {file delete $::dblfile} + + # handle some command-line arguments. + # the argument list should already be normalized: '--' => '-', "=" => ' ' + set i 0 + set do_splash 1 + set ::prelocation "..." + set ::mir_selected 1 ; # i.e. default or set by parameter + set i [llength $::argv] + while {$i > 0} { + incr i -1 + set p [lindex $::argv $i] + if {$p eq "-profile"} { + # check for profile argument: no splash screen if present + set do_splash 0 + } elseif {$p in [list "-location" "-url" "-repository" "-repos" "-repo"]} { + # check for repository argument: bail out if obviously invalid + set j [expr {$i+1}] + if {$j<[llength $::argv]} { + set p [lindex $::argv $j] + unset j + if {$p ne "ctan" && ! [possible_repository $p]} { + tk_messageBox -message [__ "%s not a local or remote repository" $p] \ + -title [__ "Error"] -type ok -icon error + exit + } + set ::prelocation $p + } else { + tk_messageBox -message [__ "%s requires an argument" $p] \ + -title [__ "Error"] -type ok -icon error + exit + } + } elseif {$p eq "-select-repository"} { + # in this case, we start with selecting a repository + # from a mirror list and modify ::argv to take the selection + # into account before contacting the perl back end. + unset -nocomplain ::mir_selected + # remove this argument + set ::argv [lreplace $::argv $i $i] + } + } + unset i + + if {$do_splash || ! [info exists ::mir_selected]} pre_splash + + if {! [info exists ::mir_selected]} { + select_mirror + } + + if $do_splash make_splash + unset do_splash + + if {! [info exist ::mir_selected]} { + vwait ::mir_selected + } + + # start install-tl-[tcl] via a pipe. + set cmd [list "|${::perlbin}" "${::instroot}/install-tl" \ + "-from_ext_gui" {*}$::argv 2>@1] + show_time "opening pipe" + if [catch {open $cmd r+} ::inst] { + err_exit "Error starting Perl backend" + } + + show_time "opened pipe" + set ::perlpid [pid $::inst] + + # for windows < 10: make sure the main window is still on top + wm attributes . -topmost + + chan configure $::inst -buffering line -blocking 1 + + # possible input from perl until the menu starts: + # - question about prior canceled installation + # - location (actual repository) + # - menu data, help, version, print-platform + set ::did_gui 0 + set answer "" + unset -nocomplain ::loaded + while 1 { ; # initial perl output + set ll [read_line] + if {[lindex $ll 0] < 0} { + break + } + set l [lindex $ll 1] + # There may be occasion for a dialog + if {$l eq "mess_yesno"} { + answer_to_perl + } elseif [string match "location: ?*" $l] { + # this one comes straight from install-tl, rather than + # from install-tl-extl.pl + # installer about to contact repository, which may + # fail and cause an indefinite delay + chan configure $::inst -blocking 0 + chan event $::inst readable read_line_loading + if [winfo exists .loading] { + .loading configure -text [__ "Trying to load %s. + +If this takes too long, press Abort or choose another repository." \ + [string range $l 10 end]] + update + } + break + } + } + # waiting till the repository has been loaded + vwait ::loaded + unset ::loaded + #puts stderr "done loading" + # resume reading from back end in blocking mode + while 1 { + set ll [read_line] + if {[lindex $ll 0] < 0} { + break + } + set l [lindex $ll 1] + if {$l eq "menudata"} { + # so we do want a menu and expect menu data, + # parsing which may take a while + read_menu_data + show_time "read menu data from perl" + set ::advanced 0 + set ::alltrees 0 + set answer [run_menu] + #if [info exists ::env(dbgui)] {puts "dbgui1: menu_ans is $::menu_ans"} + if {$answer eq "advanced"} { + # this could only happen if $::advanced was 0 + set ::advanced 1 + #if [info exists ::env(dbgui)] {puts "dbgui: Setting advanced to 1"} + set answer [run_menu] + if {$answer eq "alltrees"} { + set ::alltrees 1 + #if [info exists ::env(dbgui)] {puts "dbgui: Setting alltrees to 1"} + set answer [run_menu] + } + } + set ::did_gui 1 + break + } elseif {$l eq "startinst"} { + # use an existing profile: + set ::out_log {} + set answer "startinst" + break + } else { + lappend ::out_log $l + } + } + if {$answer eq "startinst"} { + run_installer + # invokes show_log which first destroys previous children + } else { + log_exit + } +}; # main_prog + +#file delete $::dblfile + +main_prog -- cgit v1.2.3