diff options
author | Siep Kroonenberg <siepo@cybercomm.nl> | 2018-07-06 19:55:45 +0000 |
---|---|---|
committer | Siep Kroonenberg <siepo@cybercomm.nl> | 2018-07-06 19:55:45 +0000 |
commit | 31e134c4d702cf23f137574c0a2b421f02e0bc9e (patch) | |
tree | bd6ddab726311a50772b8550625254405dec4d7d /Master/tlpkg/installer/install-tl-gui.tcl | |
parent | 6e0ef8475e8bdc664bd8bd158bd76d9d6bb5e5a4 (diff) |
Added dialog for installation root and minor improvements
git-svn-id: svn://tug.org/texlive/trunk@48152 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/installer/install-tl-gui.tcl')
-rwxr-xr-x | Master/tlpkg/installer/install-tl-gui.tcl | 403 |
1 files changed, 370 insertions, 33 deletions
diff --git a/Master/tlpkg/installer/install-tl-gui.tcl b/Master/tlpkg/installer/install-tl-gui.tcl index cfaa1c5b86c..e9895f34fa3 100755 --- a/Master/tlpkg/installer/install-tl-gui.tcl +++ b/Master/tlpkg/installer/install-tl-gui.tcl @@ -109,6 +109,9 @@ proc dblog {s} { 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 @@ proc read_line_cb {} { 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 @@ proc place_dlg {wnd {p "."}} { 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 @@ proc make_splash {} { # 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 @@ proc make_splash {} { 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 @@ proc save_bin_selections {} { } } 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 @@ proc select_scheme {} { } } update_vars + show_stats end_dlg 1 .tlschm . } ppack .tlschm.ok -in .tlschm.buts -side right @@ -521,6 +836,7 @@ proc save_coll_selections {} { } set ::vars(selected_scheme) "scheme-custom" update_vars + show_stats }; # save_coll_selections proc select_collections {} { @@ -619,6 +935,25 @@ proc select_collections {} { # 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 @@ proc run_menu {} { # 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 @@ proc run_menu {} { } ppack .quit -in .final -side right + show_stats wm state . normal unset -nocomplain ::menu_ans vwait ::menu_ans |