texlive[51454] Master: Abort option when loading a repository
commits+siepo at tug.org
commits+siepo at tug.org
Tue Jun 25 20:37:24 CEST 2019
Revision: 51454
http://tug.org/svn/texlive?view=revision&revision=51454
Author: siepo
Date: 2019-06-25 20:37:23 +0200 (Tue, 25 Jun 2019)
Log Message:
-----------
Abort option when loading a repository
Modified Paths:
--------------
trunk/Master/install-tl
trunk/Master/texmf-dist/scripts/tlshell/tlshell.tcl
trunk/Master/tlpkg/installer/install-menu-extl.pl
trunk/Master/tlpkg/installer/install-tl-gui.tcl
trunk/Master/tlpkg/tltcl/tltcl.tcl
Modified: trunk/Master/install-tl
===================================================================
--- trunk/Master/install-tl 2019-06-25 18:08:06 UTC (rev 51453)
+++ trunk/Master/install-tl 2019-06-25 18:37:23 UTC (rev 51454)
@@ -703,6 +703,7 @@
}
read_profile($opt_profile);
if ($from_ext_gui) {
+ print STDOUT "endload\n\n";
print STDOUT "startinst\n";
}
}
Modified: trunk/Master/texmf-dist/scripts/tlshell/tlshell.tcl
===================================================================
--- trunk/Master/texmf-dist/scripts/tlshell/tlshell.tcl 2019-06-25 18:08:06 UTC (rev 51453)
+++ trunk/Master/texmf-dist/scripts/tlshell/tlshell.tcl 2019-06-25 18:37:23 UTC (rev 51454)
@@ -130,6 +130,11 @@
set ::default_bg white
}
+# NOTE
+# text widgets aren't ttk widgets:
+# state disabled => configure -state disabled
+# state !disabled => configure -state normal
+
# dialog with textbox
proc long_message {str type {p "."}} {
# alternate messagebox implemented as custom dialog
@@ -252,18 +257,15 @@
set ::busy [__ "Running"]
. configure -menu .mn_empty
foreach c [winfo children .] {
- if {$c ne ".showlogs" && [winfo class $c] in \
- [list TButton TCheckbutton TRadiobutton TEntry Treeview]} {
+ if {$c ne ".showlogs" && [winfo class $c] in $::active_cls} {
# this should cover all relevant widgets in the main window
$c state disabled
}
}
- set ::busy [__ "Running"]
} else { ; # enable
. configure -menu .mn
foreach c [winfo children .] {
- if {[winfo class $c] in \
- [list TButton TCheckbutton TRadiobutton TEntry Treeview]} {
+ if {[winfo class $c] in $::active_cls} {
$c state !disabled
}
}
@@ -284,7 +286,8 @@
array unset ::repos
# mirrors: dict of dicts of lists of urls per country per continent
-set ::mirrors [dict create]
+# moved to tltcl.tcl
+#set ::mirrors [dict create]
# dict of (local and global) package dicts
set ::pkgs [dict create]
@@ -334,9 +337,12 @@
}
} ; # read_err_tempfile
-proc err_exit {} {
+proc err_exit {{m ""}} {
do_debug "error exit"
- read_err_tempfile
+ if [info exists ::err] read_err_tempfile
+ if {$m ne ""} {
+ set ::err_log [linsert $::err_log 0 $m]
+ }
any_message [join $::err_log "\n"] "ok"
exit
} ; # err_exit
@@ -350,9 +356,8 @@
# to process initial tlmgr output before continuing.
unset -nocomplain ::done_waiting
do_debug "opening tlmgr"
- if [catch \
- {open "|tlmgr $args --machine-readable shell 2>>$::err_file" w+} \
- ::tlshl] {
+ set cmd [list "|tlmgr" {*}$args "--machine-readable" "shell" 2>>$::err_file]
+ if [catch {open $cmd w+} ::tlshl] {
tk_messageBox -message [get_stacktrace]
exit
}
@@ -374,9 +379,10 @@
# if it wants to wait for the command to finish
set l "" ; # will contain the line to be read
if {([catch {chan gets $::tlshl l} len] || [chan eof $::tlshl])} {
+ # copy as much of stderr as possible to ::err_log
+ catch {read_err_tempfile ; chan close $::err}
if [chan eof $::tlshl] {
catch {chan close $::tlshl}
- catch {chan close $:err}
unset -nocomplain ::tlshl
unset -nocomplain ::err
set ::perlpid 0
@@ -433,8 +439,8 @@
proc log_widget_init {} {
show_logs ; # create the logs dialog
- .tllg.status configure -text [__ "Running"]
- .tllg.close configure -state disabled
+ set ::busy [__ "Running"]
+ .tllg.close state disabled
}
proc log_widget_add l {
@@ -453,8 +459,8 @@
if {$::tcl_platform(os) ne "Darwin"} {
.tllg.log.tx configure -state disabled
}
- .tllg.status configure -text [__ "Idle"]
- .tllg.close configure -state !disabled
+ set ::busy [__ "Idle"]
+ .tllg.close state !disabled
bind .tllg <Escape> {.tllg.close invoke}
}
@@ -470,10 +476,13 @@
if $show {
show_logs
.tllg.status configure -text [__ "Running"]
- .tllg.close configure -state disabled
+ .tllg.close state disabled
}
set l [llength $cmds]
for {set i 0} {$i<$l} {incr i} {
+ if {! [info exists ::tlshl]} {
+ err_exit "Back end gone. Last command: \n $::last_cmd"
+ }
set cmd [lindex $cmds $i]
set ::last_cmd $cmd
unset -nocomplain ::done_waiting
@@ -519,9 +528,10 @@
# The repositories play a small part in this front end. Tlmgr mostly works
# with a virtual repository, which is the combined set of repositories,
-# with pinning applied. But get_packages_info_remote must invoke
+# with pinning applied if there is more than one repository.
+# But get_packages_info_remote must invoke
# show_repositories to display updated verification info.
-# This proc is also invoked by initialize.
+# show_repositories is also invoked by initialize.
# get_packages_info_local is invoked only once, at initialization. After
# installations and removals, the collected information is updated by
@@ -528,18 +538,18 @@
# update_local_revnumbers.
# Both procs also invoke get_platforms
-# get_packages_info_remote will be invoked by collect_filtered if
-# ::have_remote is false. Afterwards, ::have_remote will be true, and
-# therefore get_packages_info_remote will not be called again.
-# get_packages_info_remot also invokes get_platforms
-# get_packages_info_remote invokes update_globals and show_repos.
+# get_packages_info_remote should be invoked before collect_filtered if
+# ::have_remote is false. Afterwards, ::have_remote will be true.
+# There will be no need to invoke get_packages_info_remote again except
+# at a change of repository by repos_commit.
+# get_packages_info_remote invokes update_globals, show_repos
+# and get_platforms.
# update_local_revnumbers will be invoked after any updates. It also
# invokes update_globals.
# collect_filtered does not only filter, but also organize the
-# information to be displayed. If necessary, it invokes
-# get_packages_info_remote and always invokes display_packages_info.
+# information to be displayed. It invokes display_packages_info.
# It is invoked at initialization, when filtering options change and
# at the end of install-, remove- and update procs.
@@ -614,8 +624,9 @@
proc collect_filtered {} {
do_debug \
"collect_filtered for $::stat_opt and $::dtl_opt"
+ # test this beforehand
if {$::stat_opt ne "inst" && ! $::have_remote} {
- get_packages_info_remote
+ err_exit "collect_filtered should not have been invoked at this time"
}
foreach nm [dict keys $::filtered] {
dict unset ::filtered $nm
@@ -717,6 +728,57 @@
get_platforms
} ; # get_packages_info_local
+proc abort_load {} {
+ # try to close back end forcibly
+ catch {chan close $::tlshl}
+ if {$::tcl_platform(platform) eq "windows"} {
+ catch {exec -ignorestderr taskkill /pid $::perlpid /t /f}
+ } else {
+ catch {exec -ignorestderr kill -9 $::perlpid}
+ # should also be ok for darwin
+ }
+ # start new tlshell process
+ exec $::progname &
+
+ # end current tlshell process nicely
+ exit
+ # kill current tlshell process forcibly if necessary
+ if {$::tcl_platform(platform) eq "windows"} {
+ catch {exec -ignorestderr taskkill /pid [pid] /t /f}
+ } else {
+ catch {exec -ignorestderr kill -9 [pid]}
+ # kill -9 should also be ok for darwin
+ }
+} ; # abort load
+
+# activate abort button
+# toplevel with abort button in case loading of a repository takes too long.
+# it should disappear if loading finishes
+proc splash_loading {} {
+
+ #toplevel .loading
+ create_dlg .loading .
+
+ wm title .loading ""
+
+ # wallpaper
+ pack [ttk::frame .loading.bg -padding 3] -fill both -expand 1
+
+ set lbl [__ "Trying to load %s.
+
+If this takes too long, press Abort and choose another repository." \
+ $::repos(main)]
+ append lbl "\n([__ "Options"] \/ [__ "Repositories"] ...)"
+ ppack [ttk::label .loading.l0 -text $lbl \
+ -wraplength [expr {60*$::cw}] -justify left] \
+ -in .loading.bg -anchor w
+ pack [ttk::frame .loading.buttons] -in .loading.bg -expand 1 -fill x
+ ttk::button .loading.y -text [__ "Abort"] -command abort_load
+ ppack .loading.y -in .loading.buttons -side right
+ wm resizable .loading 0 0
+ place_dlg .loading .
+} ; # splash_loading
+
# remote: preserve information on installed packages
proc get_packages_info_remote {} {
# remove non-local database entries
@@ -729,12 +791,15 @@
set ::updatable 0
set ::tlshell_updatable 0
- if [catch {run_cmd_waiting \
+ splash_loading
+ if [catch {run_cmd \
"info --data name,localrev,remoterev,cat-version,category,shortdesc"}] {
do_debug [get_stacktrace]
tk_messageBox -message [__ "A configured repository is unavailable."]
return 0
}
+ vwait ::done_waiting
+ destroy .loading
set re {^([^,]+),([0-9]+),([0-9]+),([^,]*),([^,]*),(.*)$}
foreach l $::out_log {
if [regexp $re $l m nm lrev rrev rcatv catg pdescr] {
@@ -804,7 +869,8 @@
pack [ttk::frame .tllg.bottom] -in .tllg.bg -side bottom -fill x
ttk::button .tllg.close -text [__ "Close"] -command {end_dlg 0 .tllg}
ppack .tllg.close -in .tllg.bottom -side right -anchor e
- ppack [ttk::label .tllg.status -anchor w] -in .tllg.bottom -side left
+ ppack [ttk::label .tllg.status -textvariable ::busy -anchor w] \
+ -in .tllg.bottom -side left
bind .tllg <Escape> {.tllg.close invoke}
wm protocol .tllg WM_DELETE_WINDOW {.tllg.close invoke}
@@ -871,123 +937,21 @@
##### repositories ###############################################
### mirrors
+#mangle_name {n} {} ; moved to tltcl.tcl
+#proc read_mirrors {} {} ; moved to tltcl.tcl
-# turn name into a string suitable for a widget name
-proc mangle_name {n} {
- set n [string tolower $n]
- set n [string map {" " "_"} $n]
- return $n
-} ; # mangle_name
-
-set mirrors [dict create]
-proc read_mirrors {} {
- if [catch {open [file join [exec kpsewhich -var-value SELFAUTOPARENT] \
- "tlpkg/installer/ctan-mirrors.pl"] r} fm] {
- do_debug "cannot open mirror list"
- return 0
- }
- set re_geo {^\s*'([^']+)' => \{\s*$}
- set re_url {^\s*'(.*)' => ([0-9]+)}
- set re_clo {^\s*\},?\s*$}
- set starting 1
- set lnum 0 ; # line number for error messages
- set ok 1 ; # no errors encountered yet
- set countries {} ; # aggregate list of countries
- set urls {} ; # aggregate list of urls
- set continent ""
- set country ""
- set u ""
- set in_cont 0
- set in_coun 0
- while {! [catch {chan gets $fm} line] && ! [chan eof $fm]} {
- incr lnum
- if $starting {
- if {[string first "\$mirrors =" $line] == 0} {
- set starting 0
- continue
- } else {
- set ok 0
- set msg "Unexpected line '$line' at start"
- break
- }
- }
- # starting is now dealt with.
- if [regexp $re_geo $line dummy c] {
- if {! $in_cont} {
- set in_cont 1
- set continent $c
- set cont_dict [dict create]
- if {$continent in [dict keys $::mirrors]} {
- set ok 0
- set msg "Duplicate continent $c at line $lnum"
- break
- }
- } elseif {! $in_coun} {
- set in_coun 1
- set country $c
- if {$country in $countries} {
- set ok 0
- set msg "Duplicate country $c at line $lnum"
- break
- }
- lappend countries $country
- dict set cont_dict $country {}
- } else {
- set ok 0
- set msg "Unexpected continent- or country line $line at line $lnum"
- break
- }
- } elseif [regexp $re_url $line dummy u n] {
- if {! $in_coun} {
- set ok 0
- set msg "Unexpected url line $line at line $lnum"
- break
- } elseif {$n ne "1"} {
- continue
- }
- append u "systems/texlive/tlnet"
- if {$u in $urls} {
- set ok 0
- set msg "Duplicate url $u at line $lnum"
- break
- }
- dict lappend cont_dict $country $u
- lappend urls $u
- set u ""
- } elseif [regexp $re_clo $line] {
- if $in_coun {
- set in_coun 0
- set country ""
- } elseif $in_cont {
- set in_cont 0
- dict set ::mirrors $continent $cont_dict
- set continent ""
- } else {
- break ; # should close mirror list
- }
- } ; # ignore other lines
- }
- close $fm
- if {! $ok} {do_debug $msg}
-} ; # read_mirrors
-
proc pick_local_repo {} {
- set tail "tlpkg/texlive.tlpdb"
set nw_repo [.tlr.cur cget -text]
- if {! [file exists [file join $nw_repo $tail]]} {
- # not local, try originally configured main repository
- set nw_repo $::repos(main)
- if {! [file exists [file join $nw_repo $tail]]} {
- # again, not local
- set nw_repo $::env(HOME) ; # HOME also o.k. for windows
- }
+ if {! [file isdirectory $nw_repo]} {
+ set nw_repo $::env(HOME) ; # HOME also o.k. for windows
}
while 1 {
set nw_repo [browse4dir $nw_repo .tlr]
- if {$nw_repo ne "" && ! [file exists [file join $nw_repo $tail]]} {
+ if {$nw_repo ne "" && ! [possible_repository $nw_repo]} {
tk_messageBox -message [__ "%s not a repository" $nw_repo] -parent .tlr
continue
} else {
+ .tlr.save state !disabled
break
}
}
@@ -998,7 +962,6 @@
} ; # pick_local_repo
proc get_repos_from_tlmgr {} {
- #puts stderr "get_repos start"
array unset ::repos
run_cmd_waiting "option repository"
set rps ""
@@ -1026,7 +989,6 @@
array unset ::repos
}
}
- #puts stderr "get_repos end"
}; # get_repos_from_tlmgr
proc set_repos_in_tlmgr {} {
@@ -1034,7 +996,6 @@
# we need to compose a string for opt_location ourselves from $::repos.
# a single repository should not get a tag.
# apparently, we can safely ignore bogus pinning data.
- #puts stderr "set_repos start"
set nr [array size ::repos]
set opt_repos ""
set rp ""
@@ -1043,8 +1004,7 @@
if {$nm ne "main"} {
err_exit "Internal error"
} else {
- # pinning only supported for multiple repositories
- run_cmd_waiting "pinning remove $nm --all"
+ # pinning command only supported for multiple repositories
set rp $::repos(main)
}
} else {
@@ -1061,12 +1021,9 @@
append opt_repos " $rp"
}
run_cmd_waiting "repository set [string range $opt_repos 1 end]"
- #puts stderr [string range $opt_repos 1 end]
- #puts stderr "set_repos end"
}; # set_repos_in_tlmgr
proc show_repos {} {
- #puts stderr "show_repos start"
set w .toprepo
foreach ch [winfo children $w] {destroy $ch}
set nms [array names ::repos]
@@ -1085,19 +1042,13 @@
pgrid [ttk::label $w.load -text [__ "Not loaded"]] \
-sticky nw -row 0 -column 1
}
- set do_veri 0
- if {$::have_remote && [dict get $::pkgs texlive.infra localrev] >= 51140} {
- set do_veri 1
- }
set repodict [dict create]
- if $do_veri {
+ if $::have_remote {
run_cmd_waiting "repository status"
set re {^(\S+) (\S+)/tlpkg/texlive.tlpdb (-?\d+) (.*)$}
foreach l $::out_log {
- #puts stderr $l
if [regexp $re $l dum nm rp n d] {
# dummy tag repository verification_code description
- #puts stderr "scanning..."
# restore spaces and percent characters in nm and rp
set nm [string map {"%20" " "} $nm]
set nm [string map {"%25" "%"} $nm]
@@ -1106,11 +1057,8 @@
dict set repodict $nm "url" $rp
dict set repodict $nm "vericode" $n
dict set repodict $nm "veridescr" $d
- #puts stderr "${nm}: $rp"
}
}
- } else {
- #puts stderr "No veri"
}
set rw 0
foreach nm [array names ::repos] {
@@ -1117,7 +1065,7 @@
incr rw
pgrid [ttk::label $w.u$nm -text $::repos($nm) -justify left] \
-sticky nw -row $rw -column 0
- if {$::repos($nm) eq $::any_mirror && $do_veri} {
+ if {$::repos($nm) eq $::any_mirror && $::have_remote} {
set s $::repos($nm)
append s "\n[__ "Actual repository"]:\n"
append s [dict get $repodict $nm "url"]
@@ -1127,17 +1075,15 @@
pgrid [ttk::label $w.n$nm -text "($nm)"] \
-sticky nw -row $rw -column 1
}
- if $do_veri {
+ if $::have_remote {
pgrid [ttk::label $w.v$nm -text \
"verification: [dict get $repodict $nm "veridescr"]"] \
-sticky nw -row $rw -column 2
}
}
- #puts stderr "show_repos end"
} ; # show_repos
proc repos_commit {} {
- #puts stderr "repos_commit start"
set changes 0
# set repositories then add pinning if appropriate
if {! [regexp {^\s*$} [.tlr.new get]]} {
@@ -1150,7 +1096,6 @@
set had_contrib 0
if $::toggle_contrib {
set changes 1
- #puts stderr "handle tlcontrib"
foreach nm [array names ::repos] {
if {$::repos($nm) eq $::tlcontrib} {
set had_contrib 1
@@ -1171,15 +1116,31 @@
if {$::toggle_contrib && ! $had_contrib} {
run_cmd_waiting "pinning add tlcontrib \"*\""
}
- # reload remote package information
- set ::have_remote 0
- get_packages_info_remote
- collect_filtered
- #puts stderr "done committing"
}
- #puts stderr "really done committing"
} ; # repos_commit
+proc dis_enable_reposave {} {
+ if [possible_repository [.tlr.new get]] {
+ .tlr.save state !disabled
+ } else {
+ .tlr.save state disabled
+ }
+}
+
+proc save_load_repo {} {
+ repos_commit
+ end_dlg "" .tlr
+ # reload remote package information
+ set ::have_remote 0
+ get_packages_info_remote
+ collect_filtered
+}
+
+proc select_mir {m} {
+ .tlr.new delete 0 end; .tlr.new insert end $m
+ .tlr.save state !disabled
+}
+
# main repository dialog
proc repository_dialog {} {
@@ -1211,6 +1172,8 @@
-in .tlr.info -row $row -column 0 -sticky w
pgrid [ttk::entry .tlr.new] \
-in .tlr.info -row $row -column 1 -columnspan 2 -sticky ew
+ .tlr.new insert 0 $::repos(main)
+ bind .tlr.new <KeyRelease> dis_enable_reposave
### three ways to specify a repository ###
pack [ttk::frame .tlr.mirbuttons] -in .tlr.bg -fill x
@@ -1218,32 +1181,12 @@
ttk::button .tlr.ctan -text [__ "Any CTAN mirror"] -command {
.tlr.new delete 0 end
.tlr.new insert end $::any_mirror
+ .tlr.save state !disabled
}
ppack .tlr.ctan -in .tlr.mirbuttons -side left -fill x
# 2. specific repository: create a cascading dropdown menu of mirrors
- destroy .tlr.mir.m
- if {[dict size $::mirrors] == 0} read_mirrors
- do_debug "[dict size $::mirrors] mirrors"
- if {[dict size $::mirrors] > 0} {
- ttk::menubutton .tlr.mir -text [__ "Specific mirror..."] \
- -direction below -menu .tlr.mir.m
- ppack .tlr.mir -in .tlr.mirbuttons -side left -fill x
- menu .tlr.mir.m
- dict for {cont d_cont} $::mirrors {
- set c_ed [mangle_name $cont]
- menu .tlr.mir.m.$c_ed
- .tlr.mir.m add cascade -label $cont -menu .tlr.mir.m.$c_ed
- dict for {cntr urls} $d_cont {
- set n_ed [mangle_name $cntr]
- menu .tlr.mir.m.$c_ed.$n_ed
- .tlr.mir.m.$c_ed add cascade -label $cntr -menu .tlr.mir.m.$c_ed.$n_ed
- foreach u $urls {
- .tlr.mir.m.$c_ed.$n_ed add command -label $u \
- -command ".tlr.new delete 0 end; .tlr.new insert end $u"
- }
- }
- }
- }
+ mirror_menu .tlr.mir select_mir
+ ppack .tlr.mir -in .tlr.mirbuttons -side left -fill x
# 3. local repository
ttk::button .tlr.browse -text [__ "Local directory..."] -command {
.tlr.new delete 0 end; .tlr.new insert end [pick_local_repo]}
@@ -1275,18 +1218,14 @@
# two ways to close the dialog
pack [ttk::frame .tlr.closebuttons] -pady [list 10 0] -in .tlr.bg -fill x
- ttk::button .tlr.save -text [__ "Save and Load"] -command {
- #puts stderr "save and load invoked"
- repos_commit
- end_dlg "" .tlr
- #puts stderr "save and load done"
- }
+ ttk::button .tlr.save -text [__ "Save and Load"] -command save_load_repo
ppack .tlr.save -in .tlr.closebuttons -side right
- ttk::button .tlr.abort -text [__ "Abort"] -command {end_dlg "" .tlr}
- ppack .tlr.abort -in .tlr.closebuttons -side right
- bind .tlr <Escape> {.tlr.abort invoke}
+ dis_enable_reposave
+ ttk::button .tlr.cancel -text [__ "Cancel"] -command {end_dlg "" .tlr}
+ ppack .tlr.cancel -in .tlr.closebuttons -side right
+ bind .tlr <Escape> {.tlr.cancel invoke}
- #wm protocol .tlr WM_DELETE_WINDOW {.tlr.abort invoke}
+ wm protocol .tlr WM_DELETE_WINDOW {.tlr.cancel invoke}
wm resizable .tlr 1 0
place_dlg .tlr .
} ; # repository_dialog
@@ -1315,10 +1254,10 @@
} else {
.tlpl.pl set $pl "sup" "[mark_sym $m0] \u21d2 [mark_sym $m1]"
}
- .tlpl.do configure -state disabled
+ .tlpl.do state disabled
dict for {p mrks} $::platforms {
if {[dict get $mrks "fut"] ne [dict get $mrks "cur"]} {
- .tlpl.do configure -state !disabled
+ .tlpl.do state !disabled
break
}
}
@@ -1367,12 +1306,14 @@
# buttons
pack [ttk::frame .tlpl.but] -in .tlpl.bg -side bottom -fill x
ttk::button .tlpl.do -text [__ "Apply and close"] -command {
- platforms_commit; end_dlg "" .tlpl
+ disable_dlg .tlpl
+ platforms_commit
+ end_dlg "" .tlpl
}
ttk::button .tlpl.dont -text [__ "Close"] -command \
{end_dlg "" .tlpl}
ppack .tlpl.do -in .tlpl.but -side right
- .tlpl.do configure -state disabled
+ #.tlpl.do state disabled
ppack .tlpl.dont -in .tlpl.but -side right
bind .tlpl <Escape> {.tlpl.dont invoke}
@@ -1421,8 +1362,8 @@
proc enable_restore {y_n} {
set st [expr {$y_n ? !disabled : disabled}]
.tlbk.bklist state $st
- .tlbk.all configure -state $st
- .tlbk.done configure -state $st
+ .tlbk.all state $st
+ .tlbk.done state $st
} ; # enable_restore
proc finish_restore {} {
@@ -1993,9 +1934,12 @@
set ::err_log {}
lappend ::out_log $mess
unset -nocomplain ::done_waiting
- # dont understand why, on windows, start_tlmgr does not trigger
- # a console window but this proc does
- if [catch {open "|$cmd 2>&1" "r"} ::capt] {
+ # treat cmd as a list, possibly of one element
+ # using a list enables a direct invocation, bypassing a shell
+ set cmd0 [lindex $cmd 0]
+ set cmd [lreplace $cmd 0 0 "|$cmd0"]
+ set cmd [list {*}$cmd 2>@1]
+ if [catch {open $cmd r} ::capt] {
tk_messageBox -message "Failure to launch $cmd"
}
chan configure $::capt -buffering line -blocking 0
@@ -2026,6 +1970,18 @@
##### main window #####
+proc try_loading_remote {} {
+ if {[possible_repository $::repos(main)]} {
+ get_packages_info_remote
+ collect_filtered
+ } else {
+ set mes [__ "%s is not a local or remote repository.
+Please configure a valid repository" $::repos(main)]
+ append mes "\n([__ "Options"] \/ [__ "Repositories"] ...)"
+ tk_messageBox -message $mes -title [__ "Error"] -type ok -icon error
+ }
+}
+
proc populate_main {} {
wm withdraw .
@@ -2063,18 +2019,19 @@
}
}
+ # inx: keeping count to record indices where needed,
+ # i.e. when an entry needs to be referenced.
+ # not all submenus need this.
+
.mn add cascade -label [__ "File"] -menu .mn.file -underline 0
menu .mn.file
- .mn.file add command -label [__ "Load default repository"] \
- -command {get_packages_info_remote; collect_filtered}
+ .mn.file add command -label [__ "Load repository"] \
+ -command try_loading_remote
.mn.file add command -command {destroy .} -label [__ "Exit"] -underline 1
- # inx: keeping count to record indices where needed,
- # i.e. when an entry needs to be referenced.
- # not all submenus need this.
-
.mn add cascade -label [__ "Actions"] -menu .mn.act -underline 0
menu .mn.act
+ set inx -1
incr inx
.mn.act add command -label [__ "Regenerate filename database"] -command \
{run_external "mktexlsr" [__ "Regenerating filename database..."]}
@@ -2162,7 +2119,7 @@
# subframe for repositories, to be filled by show_repos
pack [ttk::frame .toprepo] -in .topfl -side top -anchor w
- # various info
+ # various info, left frame
pack [ttk::frame .topfll] -in .topfl -side top -anchor nw -pady [list 6 0]
ttk::label .topfll.lluptodate -text [__ "TL Manager up to date?"] -anchor w
pgrid .topfll.lluptodate -row 2 -column 0 -sticky w
@@ -2176,7 +2133,7 @@
-wraplength [expr {60*$::cw}] -justify left -anchor w
pgrid .topfll.lcmd -row 3 -column 1 -sticky w
- # right frame
+ # various info, right frame
ppack [ttk::frame .topfr] -in .topf -side right -anchor ne
if {$::tcl_platform(platform) eq "windows"} {
pack [ttk::label .topfr.ladmin] -side top -anchor e
@@ -2203,9 +2160,15 @@
ttk::radiobutton .pkfilter.inst -text [__ "Installed"] -value inst \
-variable ::stat_opt -command collect_filtered
ttk::radiobutton .pkfilter.alls -text [__ "All"] -value all \
- -variable ::stat_opt -command collect_filtered
+ -variable ::stat_opt -command {
+ if {! $::have_remote} get_packages_info_remote
+ collect_filtered
+ }
ttk::radiobutton .pkfilter.upd -text [__ "Updatable"] -value upd \
- -variable ::stat_opt -command collect_filtered
+ -variable ::stat_opt -command {
+ if {! $::have_remote} get_packages_info_remote
+ collect_filtered
+ }
grid .pkfilter.lstat -column 0 -row 0 -sticky w -padx {3 50}
pgrid .pkfilter.inst -column 0 -row 1 -sticky w
pgrid .pkfilter.alls -column 0 -row 2 -sticky w
Modified: trunk/Master/tlpkg/installer/install-menu-extl.pl
===================================================================
--- trunk/Master/tlpkg/installer/install-menu-extl.pl 2019-06-25 18:08:06 UTC (rev 51453)
+++ trunk/Master/tlpkg/installer/install-menu-extl.pl 2019-06-25 18:37:23 UTC (rev 51454)
@@ -61,9 +61,11 @@
$::deskintdesc[1] = "Menu shortcuts";
$::deskintdesc[2] = "Launcher";
+do_remote_init();
+print STDOUT "endload\n\n";
+
# %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:
Modified: trunk/Master/tlpkg/installer/install-tl-gui.tcl
===================================================================
--- trunk/Master/tlpkg/installer/install-tl-gui.tcl 2019-06-25 18:08:06 UTC (rev 51453)
+++ trunk/Master/tlpkg/installer/install-tl-gui.tcl 2019-06-25 18:37:23 UTC (rev 51454)
@@ -63,6 +63,35 @@
set ::advanced 0
set ::alltrees 0
+proc kill_perl {} {
+ if $::perlpid {
+ catch {
+ if {$::tcl_platform(platform) eq "unix"} {
+ exec -ignorestderr kill $::perlpid
+ } else {
+ exec -ignorestderr taskkill /pid $::perlpid /t /f
+ }
+ }
+ }
+}
+
+proc err_exit {{mess ""}} {
+ if {$mess eq ""} {set mess "Error"}
+ append mess "\n" [get_stacktrace]
+ tk_messageBox -icon error -message $mess
+ # kill perl process, just in case
+ if $::perlpid {
+ catch {
+ if {$::tcl_platform(platform) eq "unix"} {
+ exec -ignorestderr kill $::perlpid
+ } else {
+ exec -ignorestderr taskkill "/pid" $::perlpid
+ }
+ }
+ }
+ exit
+} ; # err_exit
+
# warning about non-empty target tree
set ::td_warned 0
@@ -101,19 +130,19 @@
# write to a logfile which is shared with the backend.
# both parties open, append and close every time.
-#if {$::tcl_platform(os) eq "Darwin"} {
-# set ::dblfile "$::env(TMPDIR)/dblog"
-#} elseif {$::tcl_platform(platform) eq "unix"} {
-# set ::dblfile "/tmp/dblog"
-#} else {
-# set ::dblfile "$::env(TEMP)/dblog.txt"
-#}
-#proc dblog {s} {
-# set db [open $::dblfile a]
-# set t [get_stacktrace]
-# puts $db "TCL: $s\n$t"
-# close $db
-#}
+if {$::tcl_platform(os) eq "Darwin"} {
+ set ::dblfile "$::env(TMPDIR)/dblog"
+} elseif {$::tcl_platform(platform) eq "unix"} {
+ set ::dblfile "/tmp/dblog"
+} else {
+ set ::dblfile "$::env(TEMP)/dblog.txt"
+}
+proc dblog {s} {
+ set db [open $::dblfile a]
+ set t [get_stacktrace]
+ puts $db "TCL: $s\n$t"
+ close $db
+}
proc maybe_print_welcome {} {
# if the last non-empty line was "All done", then installation is completed.
@@ -124,7 +153,7 @@
for {set i [.log.tx count -lines 1.0 end]} {$i > 0} {incr i -1} {
set l [.log.tx get ${i}.0 ${i}.end]
if {$l ne ""} {
- puts $l
+ #puts $l
if {[string range $l 0 11] eq "Installed on"} {
set all_done 1
}
@@ -195,6 +224,23 @@
return $l
}; # read_line_no_eof
+# non-blocking i/o: callback for "readable" while the splash screen is up
+# and the back end tries to contact the repository
+proc read_line_loading {} {
+ set l "" ; # will contain the line to be read
+ if {([catch {chan gets $::inst l} len] || [chan eof $::inst])} {
+ catch {chan close $::inst}
+ # note. the normal way to terminate is terminating the GUI shell.
+ # This closes stdin of the child
+ } elseif {$len >= 0} {
+ if {$l eq "endload"} {
+ chan configure $::inst -blocking 1
+ chan event $::inst readable {}
+ set ::loaded 1
+ }
+ }
+}; # read_line_loading
+
# non-blocking i/o: callback for "readable" during stage 3, installation
# ::out_log should no longer be needed
proc read_line_cb {} {
@@ -201,7 +247,7 @@
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.
+ # note. the normal way to terminate is terminating the GUI shell.
# This closes stdin of the child
.close state !disabled
if [winfo exists .abort] {.abort state disabled}
@@ -215,6 +261,43 @@
}
}; # read_line_cb
+proc maybe_abort {} {
+ set ans [tk_messageBox -message [__ "Really abort?"] -type yesno \
+ -default no]
+ if {$ans eq "no"} {
+ return
+ }
+ catch {chan close $::inst}
+ kill_perl
+ exit
+}
+
+# restart installer with chosen repository
+proc select_mir {m} {
+ # edit original command line by removing any repository parameter
+ # and adding a repository parameter $m
+ set i $::argc
+ while {$i > 0} {
+ incr i -1
+ set p [lindex $::argv $i]
+ if {$p eq "-repository"} {
+ set ::argv [lreplace $::argv $i [expr {$i+1}] ""]
+ }
+ }
+ # compose command line string from $::argv
+ set i -1
+ lappend ::argv "-repository" $m
+ set cmd [linsert $::argv 0 [info nameofexecutable] [info script] "--"]
+
+ # terminate back end
+ catch {chan close $::inst}
+ kill_perl
+
+ # restart install-tl with edited command-line
+ exec {*}$cmd &
+ exit
+} ; # select_mir
+
##############################################################
##### special-purpose uses of main window: splash, log #####
@@ -221,8 +304,6 @@
proc make_splash {} {
- # wm overrideredirect . true
-
# picture and logo
catch {
image create photo tlimage -file \
@@ -235,10 +316,20 @@
# wallpaper
pack [ttk::frame .bg -padding 3] -fill both -expand 1
+ # buttons: abort button, mirrors dropdown menu
+ pack [ttk::frame .splfb] -in .bg -side bottom -fill x
+ ppack [ttk::button .spl_a -text [__ "Abort"] -command maybe_abort] \
+ -side right -in .splfb
+ ppack [mirror_menu .spl_o select_mir] -side right -in .splfb
+
+ # some text
ppack [ttk::label .text -text [__ "TeX Live Installer"] \
-font bigfont] -in .bg
- ppack [ttk::label .loading -text [__ "Loading..."]] -in .bg
+ ppack [ttk::label .loading -text [__ "Trying to load %s.
+If this takes too long, press Abort and choose another repository." \
+ $::prelocation]] -in .bg
+
wm attributes . -topmost
update
wm state . normal
@@ -249,7 +340,7 @@
proc show_log {{do_abort 0}} {
wm withdraw .
foreach c [winfo children .] {
- destroy $c
+ catch {destroy $c}
}
# wallpaper
@@ -260,16 +351,7 @@
ttk::button .close -text [__ "Close"] -command exit
ppack .close -in .bottom -side right
if $do_abort {
- ttk::button .abort -text [__ "Cancel"] -command {
- set ans [tk_messageBox -message [__ "Really abort?"] -type yesno \
- -default no]
- if {$ans eq "no"} return
- catch {chan close $::inst}
- if {$::tcl_platform(platform) eq "windows"} {
- catch {exec taskkill /pid $::perlpid /t /f}
- }
- exit
- }
+ ttk::button .abort -text [__ "Abort"] -command maybe_abort
ppack .abort -in .bottom -side right
}
bind . <Escape> {
@@ -1133,8 +1215,8 @@
wm protocol .edsyms WM_DELETE_WINDOW {.edsyms.cancel invoke}
wm resizable .edsyms 1 0
place_dlg .edsyms .
- }
-}
+ } ; # edit_symlinks
+} ; # $::tcl_platform(platform) ne "windows"
#############################################################
@@ -1149,12 +1231,12 @@
proc run_menu {} {
if [info exists ::env(dbgui)] {
- puts "\ndbgui: run_menu: advanced is now $::advanced"
- puts "dbgui: run_menu: alltrees is now $::alltrees"
+ #puts "\ndbgui: run_menu: advanced is now $::advanced"
+ #puts "dbgui: run_menu: alltrees is now $::alltrees"
}
wm withdraw .
foreach c [winfo children .] {
- destroy $c
+ catch {destroy $c}
}
# wallpaper
@@ -1181,7 +1263,7 @@
if {!$::advanced} {
ppack [ttk::button .adv -text [__ "Advanced"] -command {
set ::menu_ans "advanced"
- if [info exists ::env(dbgui)] {puts "dbgui: requested advanced"}
+ #if [info exists ::env(dbgui)] {puts "dbgui: requested advanced"}
}] -in .final -side left
}
pack [ttk::separator .seph1 -orient horizontal] \
@@ -1188,6 +1270,7 @@
-in .bg -side bottom -pady 3 -fill x
# directories, selections
+ # advanced and basic have different frame setups
if $::advanced {
pack [ttk::frame .left] -in .bg -side left -fill both -expand 1
set curf .left
@@ -1196,8 +1279,6 @@
set curf .main
}
- # labelframes do not look quite right on macos
-
# directory section
pack [ttk::frame .dirf] -in $curf -fill x
grid columnconfigure .dirf 1 -weight 1
@@ -1205,6 +1286,8 @@
if $::advanced {
incr rw
+ # labelframes do not look quite right on macos,
+ # instead, separate label widget for title
pgrid [ttk::label .dirftitle -text [__ "Installation root"] \
-font hfont] \
-in .dirf -row $rw -column 0 -columnspan 3 -sticky w
@@ -1288,7 +1371,7 @@
if {!$::alltrees} {
ttk::button .tmoreb -text [__ "More ..."] -command {
set ::menu_ans "alltrees"
- if [info exists ::env(dbgui)] {puts "dbgui: requested alltrees"}
+ #if [info exists ::env(dbgui)] {puts "dbgui: requested alltrees"}
}
pgrid .tmoreb -in .dirf -row $rw -column 2 -sticky ne
}
@@ -1363,7 +1446,7 @@
incr rw
ttk::label .lsize -text [__ "Disk space required (in MB):"]
ttk::label .size_req -textvariable ::vars(total_size)
- pgrid .lsize -in $curf -row $rw -column 0 -sticky e
+ pgrid .lsize -in $curf -row $rw -column 0 -sticky w
pgrid .size_req -in $curf -row $rw -column 1 -sticky w
########################################################
@@ -1536,10 +1619,10 @@
if {[is_nonempty $::vars(TEXDIR)] && ! $::td_warned} {
td_warn $::vars(TEXDIR)
}
- if [info exists ::env(dbgui)] {puts "dbgui: unsetting menu_ans"}
+ #if [info exists ::env(dbgui)] {puts "dbgui: unsetting menu_ans"}
unset -nocomplain ::menu_ans
vwait ::menu_ans
- if [info exists ::env(dbgui)] {puts "dbgui0: menu_ans is $::menu_ans"}
+ #if [info exists ::env(dbgui)] {puts "dbgui0: menu_ans is $::menu_ans"}
return $::menu_ans
}; # run_menu
@@ -1733,42 +1816,44 @@
wm title . [__ "TeX Live Installer"]
wm protocol . WM_DELETE_WINDOW whataboutclose
- # check for profile argument whether to put up a splash screen
+ if {[file exists $::dblfile]} {file delete $::dblfile}
+
+ # handle some command-line arguments.
+ # the argument list should already be normalized: '--' => '-', "=" => ' '
set i 0
set do_splash 1
+ set ::prelocation "..."
while {$i < $::argc} {
set p [lindex $::argv $i]
incr i
- if {[string range $p 0 7] eq "-profile" || \
- [string range $p 0 8] eq "--profile"} {
+ if {$p eq "-profile"} {
+ # check for profile argument: no splash screen if present
set do_splash 0
- break
+ incr i
+ } elseif {$p in [list "-location" "-url" "-repository" "-repos" "-repo"]} {
+ # check for repository argument: bail out if obviously invalid
+ if {$i<$::argc} {
+ set p [lindex $::argv $i]
+ if {$p ne "ctan" && ! [possible_repository $p]} {
+ tk_messageBox -message [__ "%s not a local or remote repository" $p] \
+ -title [__ "Error"] -type ok -icon error
+ exit
+ }
+ set ::prelocation $p
+ }
+ incr i
}
}
unset i
+
if $do_splash make_splash
unset do_splash
# start install-tl-[tcl] via a pipe.
- # the command must be a string, not a list.
- # therefore, arguments with spaces must be quoted.
- # although we build the command at first as a list,
- # it will be joined into a string at a second step
- set cmd [list ${::perlbin} "${::instroot}/install-tl" \
- "-from_ext_gui" {*}$::argv]
- set i 0
- while {$i<[llength $cmd]} {
- set c [lindex $cmd $i]
- if {[string first " " $c] >= 0} {
- lset cmd $i "\"$c\""
- }
- incr i
- }
- unset i
- # tk_messageBox -message [join $cmd " "] -title "debugging"
+ set cmd [list "|${::perlbin}" "${::instroot}/install-tl" \
+ "-from_ext_gui" {*}$::argv 2>@1]
show_time "opening pipe"
- if [catch {open "|[join $cmd " "] 2>@1" r+} ::inst] {
- # "2>@1" ok under Windows >= XP
+ if [catch {open $cmd r+} ::inst] {
err_exit "Error starting Perl backend"
}
show_time "opened pipe"
@@ -1777,40 +1862,69 @@
# for windows < 10: make sure the main window is still on top
wm attributes . -topmost
- # 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
- # - location (=repository)
+ # - location (actual repository)
# - menu data, help, version, print-platform
set ::did_gui 0
set answer ""
- while 1 {
+ unset -nocomplain ::loaded
+ while 1 { ; # initial perl output
set ll [read_line]
- if {[lindex $ll 0] < 0} break
+ 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,
- # which may take a while
+ } elseif [string match "location: ?*" $l] {
+ # this one comes straight from install-tl, rather than
+ # from install-tl-extl.pl
+ # installer about to contact repository, which may
+ # fail and cause an indefinite delay
+ chan configure $::inst -blocking 0
+ chan event $::inst readable read_line_loading
+ if [winfo exists .loading] {
+ .loading configure -text [__ "Trying to load %s.
+
+If this takes too long, press Abort and choose another repository." \
+ [string range $l 10 end]]
+ update
+ }
+ break
+ }
+ }
+ # waiting till the repository has been loaded
+ vwait ::loaded
+ unset ::loaded
+ #puts stderr "done loading"
+ # resume reading from back end in blocking mode
+ while 1 {
+ set ll [read_line]
+ if {[lindex $ll 0] < 0} {
+ break
+ }
+ set l [lindex $ll 1]
+ if {$l eq "menudata"} {
+ # so we do want a menu and expect menu data,
+ # parsing which may take a while
read_menu_data
show_time "read menu data from perl"
set ::advanced 0
set ::alltrees 0
set answer [run_menu]
- if [info exists ::env(dbgui)] {puts "dbgui1: menu_ans is $::menu_ans"}
+ #if [info exists ::env(dbgui)] {puts "dbgui1: menu_ans is $::menu_ans"}
if {$answer eq "advanced"} {
# this could only happen if $::advanced was 0
set ::advanced 1
- if [info exists ::env(dbgui)] {puts "dbgui: Setting advanced to 1"}
+ #if [info exists ::env(dbgui)] {puts "dbgui: Setting advanced to 1"}
set answer [run_menu]
if {$answer eq "alltrees"} {
set ::alltrees 1
- if [info exists ::env(dbgui)] {puts "dbgui: Setting alltrees to 1"}
+ #if [info exists ::env(dbgui)] {puts "dbgui: Setting alltrees to 1"}
set answer [run_menu]
}
}
@@ -1821,13 +1935,6 @@
set ::out_log {}
set answer "startinst"
break
- } elseif [string match "location: ?*" $l] {
- # this one comes straight from install-tl, rather than
- # from install-tl-extl.pl
- if [winfo exists .loading] {
- .loading configure -text [__ "Loading from %s" [string range $l 10 end]]
- update
- }
} else {
lappend ::out_log $l
}
Modified: trunk/Master/tlpkg/tltcl/tltcl.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/tltcl.tcl 2019-06-25 18:08:06 UTC (rev 51453)
+++ trunk/Master/tlpkg/tltcl/tltcl.tcl 2019-06-25 18:37:23 UTC (rev 51454)
@@ -12,11 +12,156 @@
set ::plain_unix 1
}
+if $::plain_unix {
+ # plain_unix: avoid a RenderBadPicture error on quitting.
+ # 'send' changes the shutdown sequence,
+ # which avoids triggering the bug.
+ # 'tk appname <something>' restores 'send' and avoids the bug
+ bind . <Destroy> {
+ catch {tk appname appname}
+ }
+}
+
# process ID of the perl program that will run in the background
set ::perlpid 0
+# mirrors
+
set any_mirror "http://mirror.ctan.org/systems/texlive/tlnet"
+# turn name into a string suitable for a widget name
+proc mangle_name {n} {
+ set n [string tolower $n]
+ set n [string map {" " "_"} $n]
+ return $n
+} ; # mangle_name
+
+set mirrors [dict create]
+proc read_mirrors {} {
+ if [catch {open [file join $::instroot \
+ "tlpkg/installer/ctan-mirrors.pl"] r} fm] {
+ return 0
+ }
+ set re_geo {^\s*'([^']+)' => \{\s*$}
+ set re_url {^\s*'(.*)' => ([0-9]+)}
+ set re_clo {^\s*\},?\s*$}
+ set starting 1
+ set lnum 0 ; # line number for error messages
+ set ok 1 ; # no errors encountered yet
+ set countries {} ; # aggregate list of countries
+ set urls {} ; # aggregate list of urls
+ set continent ""
+ set country ""
+ set u ""
+ set in_cont 0
+ set in_coun 0
+ while {! [catch {chan gets $fm} line] && ! [chan eof $fm]} {
+ incr lnum
+ if $starting {
+ if {[string first "\$mirrors =" $line] == 0} {
+ set starting 0
+ continue
+ } else {
+ set ok 0
+ set msg "Unexpected line '$line' at start"
+ break
+ }
+ }
+ # starting is now dealt with.
+ if [regexp $re_geo $line dummy c] {
+ if {! $in_cont} {
+ set in_cont 1
+ set continent $c
+ set cont_dict [dict create]
+ if {$continent in [dict keys $::mirrors]} {
+ set ok 0
+ set msg "Duplicate continent $c at line $lnum"
+ break
+ }
+ } elseif {! $in_coun} {
+ set in_coun 1
+ set country $c
+ if {$country in $countries} {
+ set ok 0
+ set msg "Duplicate country $c at line $lnum"
+ break
+ }
+ lappend countries $country
+ dict set cont_dict $country {}
+ } else {
+ set ok 0
+ set msg "Unexpected continent- or country line $line at line $lnum"
+ break
+ }
+ } elseif [regexp $re_url $line dummy u n] {
+ if {! $in_coun} {
+ set ok 0
+ set msg "Unexpected url line $line at line $lnum"
+ break
+ } elseif {$n ne "1"} {
+ continue
+ }
+ append u "systems/texlive/tlnet"
+ if {$u in $urls} {
+ set ok 0
+ set msg "Duplicate url $u at line $lnum"
+ break
+ }
+ dict lappend cont_dict $country $u
+ lappend urls $u
+ set u ""
+ } elseif [regexp $re_clo $line] {
+ if $in_coun {
+ set in_coun 0
+ set country ""
+ } elseif $in_cont {
+ set in_cont 0
+ dict set ::mirrors $continent $cont_dict
+ set continent ""
+ } else {
+ break ; # should close mirror list
+ }
+ } ; # ignore other lines
+ }
+ close $fm
+} ; # read_mirrors
+
+# cascading dropdown mirror menu
+# parameter cmd should be a proc which does something with the selected url
+proc mirror_menu {wnd cmd} {
+ destroy $wnd.m
+ if {[dict size $::mirrors] == 0} read_mirrors
+ if {[dict size $::mirrors] > 0} {
+ ttk::menubutton $wnd -text [__ "Specific mirror..."] \
+ -direction below -menu $wnd.m
+ menu $wnd.m
+ dict for {cont d_cont} $::mirrors {
+ set c_ed [mangle_name $cont]
+ menu $wnd.m.$c_ed
+ $wnd.m add cascade -label $cont -menu $wnd.m.$c_ed
+ dict for {cntr urls} $d_cont {
+ set n_ed [mangle_name $cntr]
+ menu $wnd.m.$c_ed.$n_ed
+ $wnd.m.$c_ed add cascade -label $cntr -menu $wnd.m.$c_ed.$n_ed
+ foreach u $urls {
+ $wnd.m.$c_ed.$n_ed add command -label $u -command "$cmd $u"
+ }
+ }
+ }
+ } else {
+ ttk::label $wnd -text [__ "No mirror list available"]
+ }
+ return $wnd
+}
+
+proc possible_repository {s} {
+ if [regexp {^(https?|ftp):\/\/.+} $s] {return 1}
+ if {[string first {file://} $s] == 0} {set s [string range $s 7 end]}
+ if [file isdirectory [file join $s "archive"]] {return 1}
+ if [file isdirectory [file join $s "texmf-dist/web2c"]] {return 1}
+ return 0
+}
+
proc get_stacktrace {} {
set level [info level]
set s ""
@@ -26,31 +171,29 @@
return $s
} ; # get_stacktrace
-proc err_exit {{mess ""}} {
- if {$mess eq ""} {set mess "Error"}
- append mess "\n" [get_stacktrace]
- if $::plain_unix {
- # plain_unix: avoid a RenderBadPicture error on quitting.
- # 'send' changes the shutdown sequence,
- # which avoids triggering the bug.
- # 'tk appname <something>' restores 'send' and avoids the bug
- bind . <Destroy> {
- catch {tk appname appname}
+proc normalize_argv {} {
+ # work back to front, to not disturb indices of unscanned list elements
+ set i $::argc
+ while 1 {
+ incr i -1
+ if {$i<0} break
+ set s [lindex $::argv $i]
+ if {[string range $s 0 1] eq "--"} {
+ set s [string range $s 1 end]
+ set ::argv [lreplace $::argv $i $i $s]
}
+ set j [string first "=" $s]
+ if {$j > 0} {
+ set s0 [string range $s 0 [expr {$j-1}]]
+ set s1 [string range $s [expr {$j+1}] end]
+ set ::argv [lreplace $::argv $i $i $s0 $s1]
+ } elseif {$j==0} {
+ err_exit "Command-line argument $s starting with \"=\""
+ } ; # else leave alone
}
- tk_messageBox -icon error -message $mess
- # kill perl process, just in case
- if $::perlpid {
- catch {
- if {$::tcl_platform(platform) eq "unix"} {
- exec -ignorestderr "kill" $::perlpid
- } else {
- exec -ignorestderr "taskkill" "/pid" $::perlpid
- }
- }
- }
- exit
-} ; # err_exit
+ set ::argc [llength $::argv]
+}
+normalize_argv
# localization support
@@ -69,24 +212,11 @@
while {$i < $::argc} {
set p [lindex $::argv $i]
incr i
- if {$p eq "-lang" || $p eq "--lang" || $p eq "-gui-lang" || \
- $p eq "--gui-lang"} {
+ if {$p eq "-lang" || $p eq "-gui-lang"} {
if {$i < $::argc} {
set ::lang [lindex $::argv $i]
break
}
- } elseif {[string range $p 0 5] eq "-lang="} {
- set ::lang [string range $p 6 end]
- break
- } elseif {[string range $p 0 6] eq "--lang="} {
- set ::lang [string range $p 7 end]
- break
- } elseif {[string range $p 0 9] eq "-gui-lang="} {
- set ::lang [string range $p 10 end]
- break
- } elseif {[string range $p 0 11] eq "--gui-lang="} {
- set ::lang [string range $p 12 end]
- break
}
}
unset i
@@ -316,6 +446,11 @@
# for example code, look at dialog.tcl, part of Tk itself
+# widget classes which can be enabled and disabled.
+# The text widget class is not included here.
+
+set ::active_cls [list TButton TCheckbutton TRadiobutton TEntry Treeview]
+
# global variable for dialog return value, in case the outcome
# must be handled by the caller rather than by the dialog itself:
set ::dialog_ans {}
@@ -358,11 +493,16 @@
grab set $wnd
} ; # place_dlg
-proc end_dlg {ans wnd} {
+# in case pressing the closing button leads to lengthy processing:
+proc disable_dlg {wnd} {
foreach c [winfo children $wnd] {
- # alternative to catch: check type with [winfo class $wnd]
- catch {$c state disabled}
+ if {[winfo class $c] in $::active_cls} {
+ catch {$c state disabled}
+ }
}
+}
+
+proc end_dlg {ans wnd} {
set ::dialog_ans $ans
set p [winfo parent $wnd]
if {$p eq ""} {set p "."}
More information about the tex-live-commits
mailing list