texlive[48152] Master/tlpkg/installer: Added dialog for installation
commits+siepo at tug.org
commits+siepo at tug.org
Fri Jul 6 21:55:45 CEST 2018
Revision: 48152
http://tug.org/svn/texlive?view=revision&revision=48152
Author: siepo
Date: 2018-07-06 21:55:45 +0200 (Fri, 06 Jul 2018)
Log Message:
-----------
Added dialog for installation root and minor improvements
Modified Paths:
--------------
trunk/Master/tlpkg/installer/install-menu-extl.pl
trunk/Master/tlpkg/installer/install-tl-gui.tcl
Added Paths:
-----------
trunk/Master/tlpkg/installer/texlion.gif
Removed Paths:
-------------
trunk/Master/tlpkg/installer/texlion.png
Modified: trunk/Master/tlpkg/installer/install-menu-extl.pl
===================================================================
--- trunk/Master/tlpkg/installer/install-menu-extl.pl 2018-07-06 17:53:52 UTC (rev 48151)
+++ trunk/Master/tlpkg/installer/install-menu-extl.pl 2018-07-06 19:55:45 UTC (rev 48152)
@@ -1,10 +1,11 @@
#!/usr/bin/env perl
-# install-menu-tcl.pl
+# install-menu-extl.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.
+# tell the frontend about all configurable options and terminate
+# this output with an agreed-upon termination string. the frontend
+# will read the package database itself. From this, it can deduce
+# collections, schemes and platforms, but not the names of
+# platforms.
# needed info:
@@ -13,7 +14,7 @@
# collections, probably per scheme
# maybe directories to be configured
-# current option values:
+# current options:
# paper size a4 | letter
# allow restricted toggle
@@ -23,19 +24,21 @@
# create symlinks | 2 aspects of desktop integration
# switch to online CTAN
-# then read the selected options back from tcl
+# then read the selected options back from the frontend
-# and finally, tee installer output to tcl to be tracked there
-# inside the log toplevel
+# when run_menu_extl reads 'startinst' from the frontend,
+# run_menu_extl returns to install-tl.
+# by then, the frontend has switched to non-blocking i/o
+# and will capture the output of the actual installation
+# inside a log window
-our %vars; # onlys contain simple scalars
+our %vars; # only contains 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;
@@ -99,7 +102,7 @@
print "endvars\n";
}
-# run_menu_tcl should be invoked by install-tl.
+# run_menu_extl should be invoked by install-tl.
sub run_menu_extl {
# make sure we have a value for total_size:
calc_depends();
@@ -121,13 +124,14 @@
}
print "endbinaries\n";
- print "endmenudata\n"; # this triggers the tcl menu
+ print "endmenudata\n"; # this triggers the frontend menu
- # read input from install-tl-gui.tcl.
- # Three cases to consider:
+ # read input from frontend / install-tl-gui.tcl.
+ # Four 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
+ # 'checkdir': check whether $vars{TEXDIR} is creatable
+ # 'startinst': done with choices, tell install-tl to
# start installation
# 'quit': tell install-tl to clean up and quit
# read from frontend
@@ -154,6 +158,14 @@
log("Illegal input '$l' from frontend");
return $MENU_ABORT;
}
+ } elsif ($l eq 'checkdir') {
+ my $td = <STDIN>;
+ chomp $td;
+ if (TeXLive::TLUtils::texdir_check($td)) {
+ print "1\n";
+ } else {
+ print "0\n";
+ }
} elsif ($l eq 'startinst') {
if (read_vars()) {
calc_depends();
Modified: trunk/Master/tlpkg/installer/install-tl-gui.tcl
===================================================================
--- trunk/Master/tlpkg/installer/install-tl-gui.tcl 2018-07-06 17:53:52 UTC (rev 48151)
+++ trunk/Master/tlpkg/installer/install-tl-gui.tcl 2018-07-06 19:55:45 UTC (rev 48152)
@@ -109,6 +109,9 @@
close $db
}
+# dummy translation function
+proc trans {fmt args} {return [format $fmt {*}$args]}
+
# what exit procs do we need?
# - plain error exit with messagebox and stacktrace
# - plain messagebox exit
@@ -162,8 +165,9 @@
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"
+ # puts stderr "read_line_cb: pipe no longer readable"
.close configure -state !disabled
+ if [winfo exists .abort] {.abort configure -state disabled}
} elseif {$len >= 0} {
# regular output
.log.tx configure -state normal
@@ -225,6 +229,9 @@
wm geometry $wnd [format "+%d+%d" $wx $wy]
wm state $wnd normal
raise $wnd $p
+ tkwait visibility $wnd
+ focus $wnd
+ grab set $wnd
} ; # place_dlg
proc end_dlg {ans wnd {p "."}} {
@@ -291,7 +298,7 @@
# picture and logo
catch {
image create photo tlimage -file \
- [file join $::instroot "tlpkg" "installer" "texlion.png"]
+ [file join $::instroot "tlpkg" "installer" "texlion.gif"]
pack [frame .white -background white] -fill x -expand 1
label .image -image tlimage -background white
pack .image -in .white
@@ -308,6 +315,319 @@
update
}; # make_splash
+#############################################################
+
+# installation root
+
+set sep [file separator]
+
+# slash flipping
+proc forward_slashify {s} {
+ regsub -all {\\} $s {/} r
+ return $r
+}
+proc native_slashify {s} {
+ if {$::tcl_platform(platform) eq "windows"} {
+ regsub -all {/} $s {\\} r
+ } else {
+ regsub -all {\\} $s {/} r
+ }
+ return $r
+}
+
+## Code to populate a node of the tree
+proc populateTree {tree node} {
+ if {[$tree set $node type] ne "directory"} {
+ set type [$tree set $node type]
+ return
+ }
+ $tree delete [$tree children $node]
+ foreach f [lsort [glob -nocomplain -directory $node *]] {
+ set type [file type $f]
+ if {$type eq "directory"} {
+ $tree insert $node end \
+ -id $f -text [file tail $f] -values [list $type]
+ # Need at least one child to make this node openable,
+ # will be deleted when actually populating this node
+ $tree insert $f 0 -text "dummy"
+ }
+ }
+ # Stop this code from rerunning on the current node
+ $tree set $node type processedDirectory
+}
+
+# Unix directory browser.
+# Also use for MacOS, because we want to see /usr.
+proc choose_dir {initdir {parent .}} {
+
+ create_dlg .browser $parent
+ wm title .browser "Browse..."
+
+ # wallpaper
+ pack [ttk::frame .browser.bg] -fill both -expand 1
+ ## Create the tree and set it up
+ pack [ttk::frame .browser.fr0] -in .browser.bg -fill both -expand 1
+ set tree [ttk::treeview .browser.tree \
+ -columns {type} -displaycolumns {} -selectmode browse \
+ -yscroll ".browser.vsb set"]
+ .browser.tree column 0 -minwidth 500 -stretch 0
+ ttk::scrollbar .browser.vsb -orient vertical -command "$tree yview"
+ # hor. scrolling does not work, but toplevel and widget are resizable
+ $tree heading \#0 -text "/"
+ $tree insert {} end -id "/" -text "/" -values [list "directory"]
+
+ populateTree $tree "/"
+ bind $tree <<TreeviewOpen>> {
+ populateTree %W [%W focus]
+ }
+ bind $tree <ButtonRelease-1> {
+ .browser.tree heading \#0 -text [%W focus]
+ }
+
+ ## Arrange the tree and its scrollbar in the toplevel
+ # horizontal scrolling does not work.
+ # possible solution: very wide treeview in smaller paned window
+ # (may as well use pack in the absence of a horizontal scrollbar)
+ grid $tree .browser.vsb -sticky nsew -in .browser.fr0
+ grid columnconfigure .browser.fr0 0 -weight 1
+ grid rowconfigure .browser.fr0 0 -weight 1
+
+ # ok and cancel buttons
+ pack [ttk::frame .browser.fr1] -in .browser.bg -fill x -expand 1
+ ppack [ttk::button .browser.ok -text "Ok"] -side right
+ ppack [ttk::button .browser.cancel -text "Cancel"] -side right
+ .browser.ok configure -command {
+ set ::dialog_ans [.browser.tree focus]
+ destroy .browser
+ }
+ .browser.cancel configure -command {
+ set ::dialog_ans ""
+ destroy .browser
+ }
+ unset -nocomplain ::dialog_ans
+
+ # navigate tree to $initdir
+ set chosenDir {}
+ foreach d [file split [file normalize $initdir]] {
+ set nextdir [file join $chosenDir $d]
+ if [file isdirectory $nextdir] {
+ if {! [$tree exists $nextdir]} {
+ $tree insert $chosenDir end -id $nextdir \
+ -text $d -values [list "directory"]
+ }
+ populateTree $tree $nextdir
+ set chosenDir $nextdir
+ } else {
+ break
+ }
+ }
+ $tree see $chosenDir
+ $tree selection set [list $chosenDir]
+ $tree focus $chosenDir
+ $tree heading \#0 -text $chosenDir
+
+ place_dlg .browser $parent
+ tkwait window .browser
+ return $::dialog_ans
+}; # choose_dir
+
+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
+ if [file isdir [.tltd.prefix_l cget -text]] {
+ .tltd.ok_b configure -state normal
+ } else {
+ .tltd.ok_b configure -state disabled
+ }
+ if {[.tltd.rel_l cget -text] eq ""} {
+ .tltd.warn configure -text \
+ [trans "TL release component highly recommended!"]
+ } else {
+ .tltd.warn configure -text ""
+ }
+ return
+} ; # update_full_path
+
+proc browse_path {} {
+ set retval [.tltd.prefix_l cget -text]
+ if {$::tcl_platform(platform) eq "unix"} {
+ set retval [choose_dir $retval .tltd]
+ } else {
+ set retval [tk_chooseDirectory \
+ -initialdir $retval -title [trans "select or type"]]
+ }
+ if {$retval eq ""} {
+ return
+ } else {
+ .tltd.prefix_l configure -text $retval
+ update_full_path
+ return
+ }
+} ; # browse_path
+
+proc edit_name {} {
+ create_dlg .tled .tltd
+ wm title .tled [trans "Directory name..."]
+ if $::plain_unix {wm attributes .tled -type dialog}
+
+ # wallpaper
+ pack [ttk::frame .tled.bg] -fill both -expand 1
+
+ # widgets
+ ttk::label .tled.l -text [trans "Change name (slashes not allowed)"]
+ pack .tled.l -in .tled.bg -padx 5 -pady 5
+ ttk::entry .tled.e -width 20 -state normal
+ 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 -expand 1
+ ttk::button .tled.ok_b -text [trans "Ok"] -command {
+ if [regexp {[\\/]} [.tled.e get]] {
+ tk_messageBox -type ok -icon error -message [trans "No slashes allowed"]
+ } else {
+ .tltd.name_l configure -text [.tled.e get]
+ update_full_path
+ destroy .tled
+ }
+ }
+ ppack .tled.ok_b -in .tled.buttons -side right -padx 5 -pady 5
+ ttk::button .tled.q_b -text [trans "Cancel"] -command {destroy .tled}
+ ppack .tled.q_b -in .tled.buttons -side right -padx 5 -pady 5
+
+ place_dlg .tled .tltd
+ # focus .tled.e; # does not help
+} ; # edit_name
+
+proc toggle_rel {} {
+ if {[.tltd.rel_l cget -text] eq ""} {
+ .tltd.rel_l configure -text $::release_year
+ } else {
+ .tltd.rel_l configure -text ""
+ }
+ update_full_path
+} ; # toggle_rel
+
+### main dialog ###
+
+proc commit_path {} {
+ # ask perl to check path
+ set new_td [forward_slashify [.tltd.path_l cget -text]]
+ chan puts $::inst "checkdir"
+ chan puts $::inst $new_td
+ chan flush $::inst
+ if {[read_line_no_eof] ne "0"} {
+ set ::vars(TEXDIR) $new_td
+ destroy .tltd
+ } else {
+ tk_messageBox -message \
+ "$new_td is forbidden or cannot be written to;
+create it outside the installer or choose something else"
+ }
+}
+
+proc change_path {} {
+
+ ### widgets ###
+
+ create_dlg .tltd .
+ wm title .tltd "Installation directory"
+
+ # wallpaper
+ pack [ttk::frame .tltd.bg] -expand 1 -fill both
+
+ # full path
+ ppack [ttk::label .tltd.path_l -font lfont] -in .tltd.bg -side top
+
+ # grid with path components and corresponding buttons
+ pack [ttk::frame .tltd.fr1] -in .tltd.bg
+ # component strings (negative => minimum value)
+ pgrid [ttk::label .tltd.prefix_l -anchor e] \
+ -in .tltd.fr1 -row 0 -column 0 -sticky e
+ pgrid [ttk::label .tltd.sep0_l -text $::sep] -in .tltd.fr1 -row 0 -column 1
+ pgrid [ttk::label .tltd.name_l -anchor center] \
+ -in .tltd.fr1 -row 0 -column 2
+ pgrid [ttk::label .tltd.sep1_l -text $::sep] -in .tltd.fr1 -row 0 -column 3
+ pgrid [ttk::label .tltd.rel_l -width 6 -anchor w] \
+ -in .tltd.fr1 -row 0 -column 4 -sticky w
+ # corresponding buttons
+ pgrid [ttk::button .tltd.prefix_b -text [trans "Change"] \
+ -command browse_path] \
+ -in .tltd.fr1 -row 1 -column 0 -sticky e
+ pgrid [ttk::button .tltd.name_b -text [trans "Change"] -command edit_name] \
+ -in .tltd.fr1 -row 1 -column 2
+ pgrid [ttk::button .tltd.rel_b -text [trans "Toggle"] -command toggle_rel] \
+ -in .tltd.fr1 -row 1 -column 4 -sticky w
+ # warning about missing release component
+ ppack [ttk::label .tltd.warn -anchor e -foreground red] \
+ -in .tltd.bg -fill x -expand 1
+
+ # windows: note about localized names
+ if {$::tcl_platform(platform) eq "windows"} {
+ ttk::label .tltd.loc -anchor w
+ .tltd.loc configure -text \
+ [trans "Localized directory names will be replaced by their real names"]
+ ppack .tltd.loc -in .tltd.bg -fill x -expand 1
+ }
+
+ # ok/cancel buttons
+ pack [ttk::frame .tltd.frbt] -in .tltd.bg -fill x -expand 1
+ ttk::button .tltd.ok_b -text [trans "Ok"] -command commit_path
+ ppack .tltd.ok_b -in .tltd.frbt -side right
+ ttk::button .tltd.cancel_b -text [trans "Cancel"] \
+ -command {destroy .tltd}
+ ppack .tltd.cancel_b -in .tltd.frbt -side right
+
+ ### initialization and callbacks ###
+
+ set val [native_slashify [file normalize $::vars(TEXDIR)]]
+ regsub {[\\/]$} $val {} val
+ .tltd.path_l configure -text $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 $::sep
+ }
+ .tltd.prefix_l configure -text $initdir
+
+ bind .tltd <Return> commit_path
+ bind .tltd <Escape> {destroy .tltd}
+
+ place_dlg .tltd
+} ; # change_path
+
+#############################################################
+
# short descriptions for collections and schemes from texlive.tlpdb,
# not from the backend
proc get_short_descs {} {
@@ -387,13 +707,7 @@
}
}
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 ""
- }
+ show_stats
}; # save_bin_selections
proc select_binaries {} {
@@ -483,6 +797,7 @@
}
}
update_vars
+ show_stats
end_dlg 1 .tlschm .
}
ppack .tlschm.ok -in .tlschm.buts -side right
@@ -521,6 +836,7 @@
}
set ::vars(selected_scheme) "scheme-custom"
update_vars
+ show_stats
}; # save_coll_selections
proc select_collections {} {
@@ -619,6 +935,25 @@
# of this array.
# We still use blocking i/o: frontend and backend wait for each other.
+proc show_stats {} {
+ # n. of additional platforms
+ if {$::tcl_platform(platform) ne "windows"} {
+ if {$::vars(n_systems_selected) < 2} {
+ .binlm configure -text "None selected"
+ } else {
+ .binlm configure -text \
+ [format "%d additional system(s) selected" \
+ [expr {$::vars(n_systems_selected) - 1}]]
+ }
+ }
+ # n. out of n. packages
+ .lcoll configure -text \
+ [format "%d out of %d collection(s)" \
+ $::vars(n_collections_selected) \
+ $::vars(n_collections_available)]
+ # diskspace: can use -textvariable here
+}
+
proc run_menu {} {
wm withdraw .
# destroy .splash
@@ -633,49 +968,50 @@
# platforms
incr rw
- pgrid [ttk::label .binl -text $::bin_descs($::vars(this_platform))] \
- -in .gridf -row $rw -column 0 -sticky w
+ ttk::label .binl0 \
+ -text "Current platform"
+ pgrid .binl0 -in .gridf -row $rw -column 0 -sticky e
+ ttk::label .binl1 \
+ -text "$::bin_descs($::vars(this_platform))"
+ pgrid .binl1 -in .gridf -row $rw -column 1 -sticky w
+
+ incr rw
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
+ ttk::button .binb -text "Additional platform(s)" -command select_binaries
+ pgrid .binb -in .gridf -row $rw -column 0 -sticky e
+ pgrid [ttk::label .binlm -text ""] -in .gridf -row $rw -column 1 -sticky w
}
# schemes
incr rw
+ ttk::button .schmb -text "Scheme" -command select_scheme
+ pgrid .schmb -in .gridf -row $rw -column 0 -sticky e
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
+ pgrid .schml -in .gridf -row $rw -column 1 -sticky w
# 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
+ ttk::button .collb -text "Customize collections" -command select_collections
+ pgrid .collb -in .gridf -row $rw -column 0 -sticky e
+ pgrid [ttk::label .lcoll -text ""] -in .gridf -row $rw -column 1 -sticky w
# 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 .lsize -text "Disk space required (in MB)"
+ pgrid .lsize -in .gridf -row $rw -column 0 -sticky e
ttk::label .size_req -textvariable ::vars(total_size)
- ppack .size_req -in .sizef -side left
+ pgrid .size_req -in .gridf -row $rw -column 1 -sticky w
# directory setup
+ incr rw
+ ttk::button .tdirb -text "Installation root" -command change_path
+ pgrid .tdirb -in .gridf -row $rw -column 0 -sticky e
+ ttk::label .tdirl -textvariable ::vars(TEXDIR)
+ pgrid .tdirl -in .gridf -row $rw -column 1 -sticky w
# 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 {
@@ -688,6 +1024,7 @@
}
ppack .quit -in .final -side right
+ show_stats
wm state . normal
unset -nocomplain ::menu_ans
vwait ::menu_ans
Added: trunk/Master/tlpkg/installer/texlion.gif
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/installer/texlion.gif
===================================================================
--- trunk/Master/tlpkg/installer/texlion.gif 2018-07-06 17:53:52 UTC (rev 48151)
+++ trunk/Master/tlpkg/installer/texlion.gif 2018-07-06 19:55:45 UTC (rev 48152)
Property changes on: trunk/Master/tlpkg/installer/texlion.gif
___________________________________________________________________
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Deleted: trunk/Master/tlpkg/installer/texlion.png
===================================================================
(Binary files differ)
More information about the tex-live-commits
mailing list