From fc3bfaff2afa7a9366c0983a6e14344815b27eda Mon Sep 17 00:00:00 2001 From: Siep Kroonenberg Date: Sat, 23 Jun 2018 07:47:59 +0000 Subject: First attempt at tcl installer git-svn-id: svn://tug.org/texlive/trunk@48073 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/installer/install-menu-extl.pl | 172 ++++++ Master/tlpkg/installer/install-tl-gui.tcl | 917 ++++++++++++++++++++++++++++ Master/tlpkg/installer/texlion.png | Bin 0 -> 22436 bytes 3 files changed, 1089 insertions(+) create mode 100644 Master/tlpkg/installer/install-menu-extl.pl create mode 100755 Master/tlpkg/installer/install-tl-gui.tcl create mode 100644 Master/tlpkg/installer/texlion.png (limited to 'Master/tlpkg') diff --git a/Master/tlpkg/installer/install-menu-extl.pl b/Master/tlpkg/installer/install-menu-extl.pl new file mode 100644 index 00000000000..ece82c2c608 --- /dev/null +++ b/Master/tlpkg/installer/install-menu-extl.pl @@ -0,0 +1,172 @@ +#!/usr/bin/env perl +# install-menu-tcl.pl + +# tell tcl about all configurable options +# and terminate this output with an agreed-upon termination string. +# tcl will read the package database itself. From this, it can deduce +# collections, schemes and platforms, but not the names of platforms. + +# needed info: + +# binaries + descriptions +# schemes +# collections, probably per scheme +# maybe directories to be configured + +# current option values: + +# paper size a4 | letter +# allow restricted toggle +# generate formats +# install docs +# install sources +# create symlinks | 2 aspects of desktop integration +# switch to online CTAN + +# then read the selected options back from tcl + +# and finally, tee installer output to tcl to be tracked there +# inside the log toplevel + +our %vars; # onlys contain simple scalars +# from install-tl: + +# The global variable %vars is an associative list which contains all +# variables and their values which can be changed by the user. +# needs to be our since TeXLive::TLUtils uses it + + +our $opt_in_place; +our $tlpdb; +our @media_available; +our $media; +our $previoustlpdb; +our @collections_std; +our $texlive_release; + +our $MENU_INSTALL = 0; +our $MENU_ABORT = 1; # no cleanup afterwards +our $MENU_QUIT = 2; + +my $RETURN = $MENU_INSTALL; + +# @fileassocdesc also defined in install-tl +$::fileassocdesc[0] = "None"; +$::fileassocdesc[1] = "Only new"; +$::fileassocdesc[2] = "All"; + +$::deskintdesc[0] = "None"; +$::deskintdesc[1] = "Menu shortcuts"; +if (win32() && is_seven()) { $::deskintdesc[2] = "Launcher"; } + +# %vars hash should eventually include each binary, collection and scheme +# as individual schalars. + +do_remote_init(); +# the above sub adds all platforms and collections to %vars +# but maybe not schemes so we add these now: + +foreach my $pkg ($tlpdb->schemes) { + $vars{$pkg}=($vars{'selected_scheme'} eq $pkg)? 1:0; +} +$vars{'scheme-custom'} = 0 unless defined $vars{'scheme-custom'}; + +sub read_vars { + my $l = ; + chomp $l; + if ($l ne 'vars') { + return 0; + } + while (1) { + $l = ; + chomp $l; + if ($l =~ /^([^:]+): (.*)$/) { + $vars{$1} = $2; + } elsif ($l eq 'endvars') { + return 1; + } else { + return 0; + } + } + return 0; +} + +sub print_vars { + print "vars\n"; + foreach my $key (sort keys %vars) { + print $key, ': ', $vars{$key}, "\n"; + } + print "endvars\n"; +} + +# run_menu_tcl should be invoked by install-tl. +sub run_menu_extl { + # make sure we have a value for total_size: + calc_depends(); + print "menudata\n"; + print_vars(); + + # tell the frontend the preferred order for schemes + my @schemes = schemes_ordered_for_presentation(); + push @schemes, "scheme-custom"; + print "schemes_order: ", join(' ', @schemes), "\n"; + # binaries + print "binaries\n"; + + # binaries aren't packages; list their descriptions here + my @binaries = $tlpdb->available_architectures; + @binaries=sort TeXLive::TLUtils::sort_archs @binaries; + foreach my $b (@binaries) { + print $b, ': ', platform_desc($b), "\n"; + } + print "endbinaries\n"; + + print "endmenudata\n"; # this triggers the tcl menu + + # read input from install-tl-gui.tcl. + # Three cases to consider: + # 'calc': the frontend wants to update its ::vars array + # after some menu choices + # 'startinst': done with choices, tell install-tl[-tcl] to + # start installation + # 'quit': tell install-tl to clean up and quit + # read from frontend + while (1) { + my $l = ; + chomp($l); + if ($l eq 'quit') { + return $MENU_QUIT; + } elsif ($l eq 'calc') { + if (read_vars()) { + if ($vars{'selected_scheme'} eq 'scheme-custom') { + calc_depends(); + } else { + select_scheme($vars{'selected_scheme'}); + } + $vars{'n_collections_selected'} = 0; + foreach my $v (keys %vars) { + if (substr($v, 0, 11) eq 'collection-' && $vars{$v}) { + $vars{'n_collections_selected'} += 1; + } + } + print_vars(); + } else { + log("Illegal input '$l' from frontend"); + return $MENU_ABORT; + } + } elsif ($l eq 'startinst') { + if (read_vars()) { + calc_depends(); + return $MENU_INSTALL; + } else { + return $MENU_ABORT; + } + } else { + return $MENU_ABORT; + } + } +} # run_menu_extl + +$::run_menu = \&run_menu_extl; + +1; diff --git a/Master/tlpkg/installer/install-tl-gui.tcl b/Master/tlpkg/installer/install-tl-gui.tcl new file mode 100755 index 00000000000..55b37756613 --- /dev/null +++ b/Master/tlpkg/installer/install-tl-gui.tcl @@ -0,0 +1,917 @@ +#!/usr/bin/env wish + +# Copyright 2018 Siep Kroonenberg + +# This file is licensed under the GNU General Public License version 2 +# or any later version. + +# Tcl/Tk wrapper 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 {}} + +# menus: disable tearoff feature +option add *Menu.tearOff 0 + +# no bold text for messages; `userDefault' indicates priority +option add *Dialog.msg.font TkDefaultFont userDefault + +## italicized items; not used +#font create it_font {*}[font configure TkDefaultFont] +#font configure it_font -slant italic + +### initialize some globals ### + +# perl installer process id +set ::perlpid 0 + +# global variable for dialogs +set ::dialog_ans {} + +set ::plain_unix 0 +if {$::tcl_platform(platform) eq "unix" && $::tcl_platform(os) ne "Darwin"} { + set ::plain_unix 1 +} + +# for help output +set ::env(NOPERLDOC) 1 + +set ::out_log {}; # list of strings + +# this file should be in $::instroot/tlpkg/installer. +# at the next release, it may be better to start the installer, perl or tcl, +# from a shell wrapper, also on unix-like platforms +# this allows automatic inclusion of '--' parameter to separate +# tcl parameters from script parameters +set ::instroot [file normalize [info script]] +set ::instroot [file dirname [file dirname [file dirname $::instroot]]] + +set ::perlbin "perl" +if {$::tcl_platform(platform) eq "windows"} { + set ::perlbin "${::instroot}/tlpkg/tlperl/bin/perl.exe" + + # shall need to run the actual installation from a batchfile, + # to prevent hundreds of dosboxes popping up. + # need to tell perl where to write profile for noninteractive install + set ::env(tmpprofile) "" + for {set i 0} {$i<10} {incr i} { + if [file exists [file join $::env(tmp) "temp${i}.profile"]] { + continue + } else { + set ::env(tmpprofile) "temp${i}.profile" + break + } + } + if {$::env(tmpprofile) eq ""} { + err_exit "Cannot create required tempfile" + } +} + +### procedures, mostly organized bottom-up ### + +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 + +# for debugging frontend-backend communication: +# write to a logfile which is shared with the backend. +# both parties open, append and close every time. +proc dblog {s} { + set db [open "/tmp/dblog" a] + set t [get_stacktrace] + puts $db "TCL: $s\n$t" + close $db +} + +# what exit procs do we need? +# - plain error exit with messagebox and stacktrace +# - plain messagebox exit +# - showing log output, maybe with appended message, +# use log toplevel for lengthy output +# is closing the pipe $::inst guaranteed to kill perl? It should be + +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 + if $::perlpid { + if {$::tcl_platform(platform) eq "unix"} { + exec -ignorestderr "kill" $::perlpid + } else { + exec -ignorestderr "taskkill" "/pid" $::perlpid + } + } + exit +} ; # err_exit + +# regular read_line +proc read_line {} { + if [catch {chan gets $::inst l} len] { + # catch [chan close $::inst] + err_exit "Error while reading from Perl backend" + } elseif {$len < 0} { + # catch [chan close $::inst] + return [list -1 ""] + } 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" + } + set l [lindex $ll 1] + # TODO: test under debug mode + return $l +}; # read_line_no_eof + +# 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 right way to terminate is terminating the GUI shell. + # This closes stdin of the child + puts stderr "read_line_cb: pipe no longer readable" + .close configure -state !disabled + } 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 + +# general gui utilities + +# width of '0', as a rough estimate of average character width +# assume height == width*2 +set ::cw [font measure TkTextFont "0"] + +# unicode symbols as fake checkboxes in ttk::treeview widgets +proc mark_sym {mrk} { + if $mrk { + return "\u25A3" ; # 'white square containing black small square' + } else { + return "\u25A1" ; # 'white square' + } +} ; # mark_sym + +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 +} + +# start new toplevel with settings appropriate for a dialog +proc create_dlg {wnd {p .}} { + 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 + raise $wnd $p +} ; # place_dlg + +proc end_dlg {ans wnd {p "."}} { + set ::dialog_ans $ans + raise $p + destroy $wnd +} ; # end_dlg + +# ATM ::out_log will be shown only at the end +proc show_log {{do_abort 0}} { + wm withdraw . + foreach c [winfo children .] { + destroy $c + } + + # wallpaper + pack [ttk::frame .bg] -fill both -expand 1 + + 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 + + pack [ttk::frame .bottom] -in .bg -side bottom -fill x + ttk::button .close -text "close" -command exit + ppack .close -in .bottom -side right; # -anchor e + if $do_abort { + ttk::button .abort -text "abort" \ + -command {catch {chan close $::inst}; exit} + ppack .abort -in .bottom -side right + } + + set h [expr {40 * $::cw}] + set w [expr {80 * $::cw}] + wm geometry . "${w}x${h}" + wm state . normal +}; # 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 + +proc make_splash {} { + # picture and logo + catch { + image create photo tlimage -file \ + [file join $::instroot "tlpkg" "installer" "texlion.png"] + pack [frame .white -background white] -fill x -expand 1 + label .image -image tlimage -background white + pack .image -in .white + } + # wallpaper + pack [ttk::frame .bg] -fill both -expand 1 + + ppack [ttk::label .text -text "TeX Live 2018" -font bigfont] \ + -in .bg + ppack [ttk::label .loading -text "Loading..."] -in .bg + + wm state . normal + raise . + update +}; # make_splash + +# short descriptions for collections and schemes from texlive.tlpdb +# not from the backend +proc get_short_descs {} { + set dbfile [file join $::instroot "tlpkg/texlive.tlpdb"] + set fid [open $dbfile r] + # add some error checking + chan configure $fid -translation auto + set blob [read $fid] + chan close $fid + set lines [split $blob "\n"] + set nm "" + set shortdesc "" + set category "" + # make sure there is a terminator empty line for the last entry + lappend lines "" + set nm "" + foreach l $lines { + if {$l eq ""} { + # end of entry + if {$nm ne ""} { + if {$category eq "Collection"} { + set ::coll_descs($nm) $shortdesc + } elseif {$category eq "Scheme"} { + set ::scheme_descs($nm) $shortdesc + } + } + set nm "" + set category "" + set shortdesc "" + } elseif [string equal -length 5 "name " $l] { + set nm [string range $l 5 end] + if {$nm eq ""} {err_exit "Empty name in database"} + } elseif {$nm eq ""} { + err_exit "No database entry defined" + } elseif [string equal -length 9 "category " $l] { + set category [string range $l 9 end] + } elseif [string equal -length 10 "shortdesc " $l] { + set shortdesc [string range $l 10 end] + } else { + # disregard other database info + continue + } + } + set ::scheme_descs(scheme-custom) "Custom scheme" +}; # get_short_descs + +# 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 + +### binaries ### + +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 + if {$::vars(n_systems_selected) > 1} { + .binlm configure -text \ + [format "%d additional platform(s)" \ + [expr {$::vars(n_systems_selected) - 1}]] + } else { + .binlm configure -text "" + } +}; # save_bin_selections + +proc select_binaries {} { + create_dlg .tlbin . + wm title .tlbin "Binaries" + + # wallpaper + pack [ttk::frame .tlbin.bg] -expand 1 -fill both + + 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 {} \ + -height 15 -selectmode extended -yscrollcommand {.tlbin.binsc set} + + ttk::scrollbar .tlbin.binsc -orient vertical -command {.tlbin.lst yview} + .tlbin.lst column mk -width [expr {$::cw * 3}] + .tlbin.lst column desc -width $max_width + foreach b [array names ::bin_descs] { + set bb "binary_$b" + .tlbin.lst insert {} end -id $b -values \ + [list [mark_sym $::vars($bb)] $::bin_descs($b)] + } + ppack .tlbin.lst -in .tlbin.binsf -side left -expand 1 -fill both + ppack .tlbin.binsc -in .tlbin.binsf -side right -expand 1 -fill y + 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]} + + # ok, cancel buttons + pack [ttk::frame .tlbin.buts] -in .tlbin.bg -expand 1 -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 + + place_dlg .tlbin . + tkwait window .tlbin + return $::dialog_ans +}; # select_binaries + +### scheme ### +proc select_scheme {} { + create_dlg .tlschm . + wm title .tlschm "Schemes" + + # wallpaper + pack [ttk::frame .tlschm.bg] -fill both -expand 1 + + 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" -width $max_width -stretch 1 + ppack .tlschm.lst -in .tlschm.bg -fill x -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)] + pack [ttk::frame .tlschm.buts] -in .tlschm.bg -expand 1 -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 + 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 + + place_dlg .tlschm . + tkwait window .tlschm + return $::dialog_ans +}; # 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 +}; # save_coll_selections + +proc select_collections {} { + # 2017: more than 40 collections + # The tcl installer acquires collections from the database file, + # but install-tl also has an array of collections. + # Use treeview for checkbox column and 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] + + # Treeview and scrollbar for non-language- and language collections resp. + pack [ttk::frame .tlcoll.both] -in .tlcoll.bg -expand 1 -fill y + + set max_width 0 + foreach c [array names ::coll_descs] { + set cl [font measure TkTextFont $::coll_descs($c)] + if {$cl > $max_width} {set max_width $cl} + } + incr max_width 10 + foreach t {"lang" "other"} { + set wgt ".tlcoll.$t" + pack [ttk::frame ${wgt}f] \ + -in .tlcoll.both -side left -fill y + + ttk::treeview $wgt -columns {mk desc} -show {headings} \ + -height 20 -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" + } + + ttk::scrollbar ${wgt}sc -orient vertical -command "$wgt yview" + $wgt column mk -width [expr {$::cw * 3}] + $wgt column desc -width $max_width + ppack $wgt -in ${wgt}f -side left + ppack ${wgt}sc -in ${wgt}f -side left -fill y + + bind $wgt {toggle_coll %W [%W focus]} + bind $wgt {toggle_coll %W [%W focus]} + bind $wgt {toggle_coll %W [%W identify item %x %y]} + } + + foreach c [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)] + } + + # select none, select all, ok and cancel buttons + pack [ttk::frame .tlcoll.butf] -fill x + ttk::button .tlcoll.all \ + -text "Select all" \ + -command \ + {foreach wgt {.tlcoll.other .tlcoll.lang} { + foreach c [$wgt children {}] {$wgt set $c "mk" [mark_sym 1]} + } + } + ppack .tlcoll.all -in .tlcoll.butf -side left + ttk::button .tlcoll.none \ + -text "Select none" \ + -command \ + {foreach wgt {.tlcoll.other .tlcoll.lang} { + foreach c [$wgt children {}] {$wgt set $c "mk" [mark_sym 0]} + } + } + ppack .tlcoll.none -in .tlcoll.butf -side left + # the final two buttons close the menu toplevel + 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 + + place_dlg .tlcoll . + wm resizable .tlcoll 0 0 + tkwait window .tlcoll + return $::dialog_ans +}; # select_collections + +# 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. + +proc run_menu {} { + wm withdraw . + # destroy .splash + foreach c [winfo children .] { + destroy $c + } + + # wallpaper and grid + pack [ttk::frame .bg] -fill both -expand 1 + pack [ttk::frame .gridf] -in .bg -fill x -expand 1 + set rw -1 + + # platforms + incr rw + pgrid [ttk::label .binl -text $::bin_descs($::vars(this_platform))] \ + -in .gridf -row $rw -column 0 -sticky w + if {$::tcl_platform(platform) ne "windows"} { + grid [ttk::frame .plf] -in .gridf -row $rw -column 1 -sticky ew + ttk::button .binb -text "More platforms.." -command select_binaries + ppack .binb -in .plf -side right + ppack [ttk::label .binlm -text ""] -in .plf -side left + } + + # schemes + incr rw + ttk::label .schml -textvariable ::vars(selected_scheme) + pgrid .schml -in .gridf -row $rw -column 0 -sticky w + ttk::button .schmb -text "Schemes" -command select_scheme + pgrid .schmb -in .gridf -row $rw -column 1 -sticky e + + # collections + incr rw + grid [ttk::frame .collf] -in .gridf -row $rw -column 0 -sticky w + ttk::label .ncolls -textvariable ::vars(n_collections_selected) + ppack .ncolls -in .collf -side left + ttk::label .lcoll -text \ + [format "out of %d collection(s)" $::vars(n_collections_available)] + ppack .lcoll -in .collf -side left + ttk::button .collb -text "Customize selection" -command select_collections + pgrid .collb -in .gridf -row $rw -column 1 -sticky e + + # total size + incr rw + grid [ttk::frame .sizef] -in .gridf -row $rw -column 0 + ttk::label .lsize -text "Disk space required (in MB): " + ppack .lsize -in .sizef -side left + ttk::label .size_req -textvariable ::vars(total_size) + ppack .size_req -in .sizef -side left + + + # directory setup + + # options + + # required disk space + incr rw + + # final buttons + pack [ttk::frame .final] -in .bg -side bottom -fill x -expand 1 + ttk::button .install -text "Install" -command { + set ::menu_ans "startinst" + } + ppack .install -in .final -side right + ttk::button .quit -text "Quit" -command { + set ::out_log {} + set ::menu_ans "no_inst" + } + ppack .quit -in .final -side right + + wm state . normal + unset -nocomplain ::menu_ans + vwait ::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 update this array. + +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: 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. + + 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] { + #if [info exists ::bin_descs($k)] { + # puts stderr "Duplicate key $k in binaries section" + #} + 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 configure -state disabled + # startinst: does not makes sense for a profile installation + if $::did_gui { + chan puts $::inst "startinst" + write_vars + } + # windows: do profile installation via a batchfile, + # to prevent hundreds of dosboxes popping up. + # for simplicity, use install-tl-windows.bat + # with the original command-line arguments minus + # gui- and old profile command-line arguments + if {$::tcl_platform(platform) eq "windows"} { + # do not want to be asked again about aborted installation: + file delete "installation.profile" + catch {chan close $::inst}; # should already have been closed by backend + set newargs {} + set i 0 + while {$i<$::argc} { + set a [lindex $::argv $i] + # gui-related? + if [string equal -length 2 $a "--"] { + set a [string range $a 1 end] + } + if [string equal -length 4 $a "-gui"] { + incr $i + if {$i < $::argc} { + set b [lindex $::argv $i] + if {[string index $b 0] ne "-"} { + # gui parameter; skip too + incr $i + } + } + } elseif [string equal -length 8 $a "-profile"] { + incr $i + if {$i < $::argc} { + set b [lindex $::argv $i] + if {[string index $b 0] ne "-"} { + # profile parameter; skip too + incr $i + } + } + } else { + lappend newargs $a + incr $i + } + } + set cmd [list "${::instroot}/install-tl-windows.bat" {*}$newargs \ + "-profile" $::env(tmpprofile)] + if [catch {open "|[join $cmd " "] 2>@1" r+} ::inst] { + err_exit "Error starting actual installation" + } + } + # - non-blocking i/o + chan configure $::inst -buffering line -blocking 0 + chan event $::inst readable read_line_cb +}; # run_installer + +proc main_prog {} { + + wm title . "TeX Live 2018 Installer" + make_splash + + # start install-tl-[tcl] via a pipe + set cmd [list ${::perlbin} "${::instroot}/install-tl" \ + "-from_ext_gui" {*}$::argv] + if [catch {open "|[join $cmd " "] 2>@1" r+} ::inst] { + # "2>@1" ok under Windows >= XP + err_exit "Error starting Perl backend" + } + set ::perlpid [pid $::inst] + + # do not start event-driven, non-blocking io + # until the actual installation starts + chan configure $::inst -buffering line -blocking 1 + + # possible input from perl until the menu starts: + # - question about prior canceled installation + # - menu data, help, version, print-platform + set ::did_gui 0 + set answer "" + while 1 { + 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 {$l eq "menudata"} { + # we do want a menu, so we expect menu data + # this may take a while, so we put up a splash screen + #make_splash + read_menu_data + get_short_descs ; # read short descriptions from TL package database + 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 + } +} + +#file delete "/tmp/dblog" +main_prog diff --git a/Master/tlpkg/installer/texlion.png b/Master/tlpkg/installer/texlion.png new file mode 100644 index 00000000000..4040faddf7e Binary files /dev/null and b/Master/tlpkg/installer/texlion.png differ -- cgit v1.2.3