Abort option when loading a repository

git-svn-id: svn://tug.org/texlive/trunk@51454 c570f23f-e606-0410-a88d-b1316a301751

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 "."}