diff options
Diffstat (limited to 'Master/tlpkg/tltcl')
| -rw-r--r-- | Master/tlpkg/tltcl/tltcl.tcl | 220 |
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 "."} |