summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tltcl
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2019-06-25 18:37:23 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2019-06-25 18:37:23 +0000
commit51ee301a87deaf031c16009df3816a64474d99e2 (patch)
tree4a78bcb4e8964440307d5e99025aa2453ec00ac0 /Master/tlpkg/tltcl
parentf54c4102a4fa80fbfe5d00096fd31ebd13d9ab5c (diff)
Abort option when loading a repository
git-svn-id: svn://tug.org/texlive/trunk@51454 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tltcl')
-rw-r--r--Master/tlpkg/tltcl/tltcl.tcl220
1 files changed, 180 insertions, 40 deletions
diff --git a/Master/tlpkg/tltcl/tltcl.tcl b/Master/tlpkg/tltcl/tltcl.tcl
index c7e4fedb481..db0157a6d84 100644
--- a/Master/tlpkg/tltcl/tltcl.tcl
+++ b/Master/tlpkg/tltcl/tltcl.tcl
@@ -12,11 +12,156 @@ if {$::tcl_platform(platform) eq "unix" && $::tcl_platform(os) ne "Darwin"} {
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 @@ proc get_stacktrace {} {
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}
- }
- }
- 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
- }
+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
}
- exit
-} ; # err_exit
+ set ::argc [llength $::argv]
+}
+normalize_argv
# localization support
@@ -69,24 +212,11 @@ proc load_translations {} {
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 @@ set ::env(NOPERLDOC) 1
# 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 @@ proc place_dlg {wnd {p "."}} {
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 "."}