texlive[48073] Master/tlpkg/installer: First attempt at tcl installer
commits+siepo at tug.org
commits+siepo at tug.org
Sat Jun 23 09:47:59 CEST 2018
Revision: 48073
http://tug.org/svn/texlive?view=revision&revision=48073
Author: siepo
Date: 2018-06-23 09:47:59 +0200 (Sat, 23 Jun 2018)
Log Message:
-----------
First attempt at tcl installer
Added Paths:
-----------
trunk/Master/tlpkg/installer/install-menu-extl.pl
trunk/Master/tlpkg/installer/install-tl-gui.tcl
trunk/Master/tlpkg/installer/texlion.png
Added: trunk/Master/tlpkg/installer/install-menu-extl.pl
===================================================================
--- trunk/Master/tlpkg/installer/install-menu-extl.pl (rev 0)
+++ trunk/Master/tlpkg/installer/install-menu-extl.pl 2018-06-23 07:47:59 UTC (rev 48073)
@@ -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 = <STDIN>;
+ chomp $l;
+ if ($l ne 'vars') {
+ return 0;
+ }
+ while (1) {
+ $l = <STDIN>;
+ 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 = <STDIN>;
+ 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;
Property changes on: trunk/Master/tlpkg/installer/install-menu-extl.pl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/installer/install-tl-gui.tcl
===================================================================
--- trunk/Master/tlpkg/installer/install-tl-gui.tcl (rev 0)
+++ trunk/Master/tlpkg/installer/install-tl-gui.tcl 2018-06-23 07:47:59 UTC (rev 48073)
@@ -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 <space> {toggle_bin [.tlbin.lst focus]}
+ bind .tlbin.lst <Return> {toggle_bin [.tlbin.lst focus]}
+ bind .tlbin.lst <ButtonRelease-1> \
+ {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 <space> {toggle_coll %W [%W focus]}
+ bind $wgt <Return> {toggle_coll %W [%W focus]}
+ bind $wgt <ButtonRelease-1> {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
Property changes on: trunk/Master/tlpkg/installer/install-tl-gui.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/installer/texlion.png
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/installer/texlion.png
===================================================================
--- trunk/Master/tlpkg/installer/texlion.png 2018-06-23 00:18:04 UTC (rev 48072)
+++ trunk/Master/tlpkg/installer/texlion.png 2018-06-23 07:47:59 UTC (rev 48073)
Property changes on: trunk/Master/tlpkg/installer/texlion.png
___________________________________________________________________
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
More information about the tex-live-commits
mailing list