Added messagebox for long messages

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

1 files changed, 171 insertions, 71 deletions

diff --git a/Master/texmf-dist/scripts/tlshell/tlshell.tcl b/Master/texmf-dist/scripts/tlshell/tlshell.tcl
index aa539ac90b8..c7ef43d4dfc 100755
--- a/Master/texmf-dist/scripts/tlshell/tlshell.tcl
+++ b/Master/texmf-dist/scripts/tlshell/tlshell.tcl
@@ -23,13 +23,13 @@ catch {rename send {}}
 # menus: disable tearoff feature
 option add *Menu.tearOff 0
 
+# no bold text for messages
+option add *Dialog.msg.font TkDefaultFont userDefault
 set plain_unix 0
 if {$::tcl_platform(platform) eq "unix" && \
         $::tcl_platform(os) ne "Darwin"} {
   set plain_unix 1
 }
-set any_unix 0
-if {$::tcl_platform(platform) eq "unix"} {set any_unix 1}
 
 set test {}
 set ddebug 0
@@ -136,18 +136,15 @@ set search_desc 0
 set prmpt "tlmgr>"
 set busy 0
 
-# TODO:
-# replace messagebox with a custom toplevel with a text widget
-# in case there is a lot of text
 proc err_exit {} {
   do_debug "error exit"
-  read_err
-  tk_messageBox -message [join $::err_log "\n"] -type ok -icon error
+  read_err_output
+  any_message [join $::err_log "\n"] "ok"
   exit
 }
 
-proc read_err {} {
-  #do_debug "read_err"
+proc read_err_output {} {
+  #do_debug "read_err_output"
   set len 0
   while 1 {
     set len [chan gets $::err l]
@@ -157,7 +154,7 @@ proc read_err {} {
       break
     }
   }
-}
+} ; # read_err_output
 
 # about [chan] gets:
 # if a second parameter, in this case l, is supplied
@@ -182,7 +179,7 @@ proc read_line {} {
     if {[string first $::prmpt $l] == 0} {
       # prompt line: done with command
       enable_widgets 1 ; # this may have to be redone later
-      read_err
+      read_err_output
       if {$::pipe_cb ne ""} {
         do_debug "prompt found, $l"
         $::pipe_cb "finish"
@@ -251,7 +248,7 @@ proc log_widget_cb {mode {l ""}} {
     .lw.status configure -text "Running"
     .lw.close configure -state disabled
     wm state .lw normal
-    wm deiconify .lw ;# also raises the window
+    raise .lw .
   } elseif {$mode eq "finish"} {
     .lw.log.tx yview moveto 1
     .lw.logs select .lw.log
@@ -308,7 +305,8 @@ proc run_entry {} {
 # The 'globals' are:
 
 # ::have_remote is initialized to false. It is set to true by
-# get_packages_info_remote, and remains true.
+# get_packages_info_remote, and remains true except temporarily at
+# a change of repository.
 
 # The other globals ones are ::n_updates, ::need_update_tlmgr and
 # ::tlshell_updatable. These are initially set to 0 and re-calculated
@@ -322,7 +320,7 @@ proc run_entry {} {
 # by update_globals, both via the enable_update_buttons proc
 
 # get_packages_info_local is invoked only once, at initialization.  After
-# installations and removals, the collected information is corrected by
+# installations and removals, the collected information is updated by
 # update_local_revnumbers.
 
 # get_packages_info_remote will be invoked by collect_filtered if
@@ -617,7 +615,7 @@ proc update_all {} {
 
 ### doing something with some packages
 
-proc pkgs_option {opt {nm ""}} {
+proc pkglist_from_option {opt {pk ""}} {
   if {$opt eq "marked"} {
     set pks {}
     dict for {p props} $::pkgs {
@@ -627,20 +625,13 @@ proc pkgs_option {opt {nm ""}} {
     set p [.pkglist focus]
     if {$p ne {}} {lappend pks $p}
   } elseif {$opt eq "name"} {
-    lappend pks $nm
+    lappend pks $pk
   }
   return $pks
-} ; # pkgs_option
-
-proc after_package_changes {} {
-  update_local_revnumbers
-  collect_filtered
-  wm state .lw normal
-  place_wrt .lw .
-} ; # after_package_changes
+} ; # pkglist_from_option
 
 proc install_pkgs {sel_opt {pk ""}} {
-  set pks [pkgs_option $sel_opt $pk]
+  set pks [pkglist_from_option $sel_opt $pk]
   # check whether packages are installed
   set pre_installed {}
   set todo {}
@@ -665,9 +656,8 @@ proc install_pkgs {sel_opt {pk ""}} {
     }
   }
   if {[llength $deps] > 0} {
-    set ans [tk_messageBox -message \
-             "Also installing dependencies $deps.\nContinue?" \
-                 -type yesno -icon question]
+    set ans [any_message \
+       "Also installing dependencies\n\n$deps.\n\nContinue?" "okcancel"]
     if {$ans eq "cancel"} return
   }
   run_cmd "install $todo" log_widget_cb
@@ -676,11 +666,12 @@ proc install_pkgs {sel_opt {pk ""}} {
     lappend ::err_log "Already installed: $pre_installed"
     show_err_log
   }
-  after_package_changes
+  update_local_revnumbers
+  collect_filtered
 } ; # install_pkgs
 
 proc update_pkgs {sel_opt {pk ""}} {
-  set pks [pkgs_option $sel_opt $pk]
+  set pks [pkglist_from_option $sel_opt $pk]
   # check whether packages are installed
   set not_inst {}
   set uptodate {}
@@ -702,7 +693,41 @@ proc update_pkgs {sel_opt {pk ""}} {
     tk_messageBox -message "Nothing to do!" -type ok -icon info
     return
   }
-  run_cmd "update $todo" log_widget_cb
+  run_cmd_waiting "update --dry-run $todo"
+  # check whether dependencies are going to be updated
+  set r {^(\S+)\s+u\s}
+  set deps {}
+  foreach l $::out_log {
+    if {[regexp $r $l d p] && $p ni $pks} {
+      lappend deps $p
+    }
+  }
+  if {[llength $deps] > 0} {
+    set ans [any_message "Also updating dependencies\n\n$deps?" \
+       "yesnocancel"]
+    switch $ans {
+      "cancel" return
+      "yes" {run_cmd "update $todo" log_widget_cb}
+      "no" {
+        set deps {}
+        run_cmd_waiting "update --dry-run --no-depends $todo"
+        foreach l $::out_log {
+          if {[regexp $r $l u p] && $p ni $pks} {
+            lappend deps $p
+          }
+        }
+        if {[llength $deps] > 0} {
+          set ans [any_message \
+                       "Updating hard dependencies $deps anyway. Continue?" \
+                       "okcancel"]
+          if {$ans eq "cancel"} return
+        }
+        run_cmd "update --no-depends $todo" log_widget_cb
+      }
+    }
+  } else {
+    run_cmd "update $todo" log_widget_cb
+  }
   vwait ::done_waiting
   if {[llength $not_inst] > 0} {
     lappend ::err_log "Skipped because not installed: $not_inst"
@@ -713,11 +738,12 @@ proc update_pkgs {sel_opt {pk ""}} {
   if {[llength $not_inst] > 0 || [llength $uptodate] > 0} {
     show_err_log
   }
-  after_package_changes
+  update_local_revnumbers
+  collect_filtered
 } ; # update_pkgs
 
 proc remove_pkgs {sel_opt {pk ""}} {
-  set pks [pkgs_option $sel_opt $pk]
+  set pks [pkglist_from_option $sel_opt $pk]
   # check whether packages are installed
   set not_inst {}
   set todo {}
@@ -742,13 +768,27 @@ proc remove_pkgs {sel_opt {pk ""}} {
     return
   }
   if {[llength $deps] > 0} {
-    set ans [tk_messageBox -message \
-             "Also remove dependencies $deps?" \
-                 -type yesnocancel -icon question]
+    set ans [any_message "Also remove dependencies\n\n$deps?" \
+                "yesnocancel"]
     switch $ans {
       "cancel" return
       "yes" {run_cmd "remove $todo" log_widget_cb}
-      "no" {run_cmd "remove --no-depends $todo" log_widget_cb}
+      "no" {
+        set deps {}
+        run_cmd_waiting "remove --dry-run --no-depends $todo"
+        foreach l $::out_log {
+          if {[regexp $r $l d p] && $p ni $pks} {
+            lappend deps $p
+          }
+        }
+        if {[llength $deps] > 0} {
+          set ans [any_message \
+                       "Removing hard dependencies $deps anyway. Continue?" \
+                       "okcancel"]
+          if {$ans eq "cancel"} return
+        }
+        run_cmd "remove --no-depends $todo" log_widget_cb
+      }
     }
   } else {
     run_cmd "remove $todo" log_widget_cb
@@ -758,7 +798,8 @@ proc remove_pkgs {sel_opt {pk ""}} {
     lappend ::err_log "Skipped because not installed: $not_inst"
     show_err_log
   }
-  after_package_changes
+  update_local_revnumbers
+  collect_filtered
 } ; # remove_pkgs
 
 #proc restore_pkgs {sel_opt {pk ""}} {
@@ -766,17 +807,6 @@ proc remove_pkgs {sel_opt {pk ""}} {
 
 ## package popup ##
 
-#proc run_package_cmd {cmd {chg 0}} {
-#  set mn [.pkglist focus]
-#  run_cmd "$cmd $mn" log_widget_cb
-#  vwait ::done_waiting
-#  if $chg {
-#    do_debug "Package_cmd $cmd; should call update_local_revnumbers"
-#    update_local_revnumbers
-#    collect_filtered
-#  }
-#} ; # run_package_cmd
-
 proc do_package_popup {x y X Y} {
   # as focused item, the identity of the item will be globally available:
   .pkglist focus [.pkglist identify item $x $y]
@@ -835,20 +865,16 @@ proc notyet {} {
 if [catch {ttk::style lookup TFrame -background} ::default_bg] {
   set ::default_bg white
 }
-# The background color of a toplevel is 'set' by covering it
-# with a background ttk::frame.
-# Under MacOS we get the wrong answer with ttk::style lookup,
-# and the default is not right either.
 
 # place a toplevel centered wrt its parent.
 # if the geometry of the new toplevel cannot be determined,
-# its top left corner will be centered wrt its parent, which is not too bad.
+# its upperleft corner will be centered wrt its parent, which is not too bad.
 proc place_wrt {wnd {p ""}} {
   if {$p eq ""} {
     set p [winfo [winfo toplevel parent $wnd]]
     if {$p eq ""} return
   }
-  update ; # try to ensure that geometry info is current
+  update ; # try to make geometry info current; does not always work
   set g [wm geometry $p]
   scan $g "%dx%d+%d+%d" pw ph px py
   set hcenter [expr $px + $pw / 2]
@@ -862,14 +888,81 @@ proc place_wrt {wnd {p ""}} {
   wm geometry $wnd [format "+%d+%d" $wx $wy]
   wm attributes $wnd -topmost 1
   wm attributes $p -topmost 0
-  wm deiconify $wnd
+  wm state $wnd normal
   raise $wnd $p
 } ; # place_wrt
 
+
+proc long_message {str type {p "."}} {
+  # custom dialog
+  # not all types are supported
+  if {$type ne "ok" && $type ne "okcancel" && $type ne "yesnocancel"} {
+    err_exit "Illegal type $type for long_message"
+  }
+  set ::lms_parent $p
+  unset -nocomplain ::lms_var
+  do_debug "type $type"
+  catch {destroy .lms}
+  toplevel .lms -class Dialog
+  wm withdraw .lms
+  wm transient .lms .
+  if $::plain_unix {wm attributes .lms -type dialog}
+
+  # wallpaper frame; see make_widgets:
+  pack [ttk::frame .lms.bg] -fill both -expand 1
+  ppack [ttk::frame .lms.tx] -in .lms.bg -side top -fill both -expand 1
+  pack [ttk::scrollbar .lms.tx.scroll -command ".lms.tx.txt yview"] \
+      -side right -fill y
+  ppack [text .lms.tx.txt -height 20 -width 60 -bd 2 -relief groove \
+      -wrap word -yscrollcommand ".lms.tx.scroll set"] -expand 1 -fill both
+
+  .lms.tx.txt insert end $str
+  .lms.tx.txt configure -state disabled
+
+  # buttons
+  pack [ttk::frame .lms.bts] -in .lms.bg -side bottom -fill x
+  if {$type eq "ok" || $type eq "okcancel"} {
+    ttk::button .lms.ok -text "ok" -command \
+        {raise $::lms_parent; destroy .lms; set ::lms_var "ok"}
+    ppack .lms.ok -in .lms.bts -side right
+  }
+  if {$type eq "yesnocancel"} {
+    ttk::button .lms.yes -text "yes" -command \
+      {raise $::lms_parent; destroy .lms; set::lms_var "yes"}
+    ppack .lms.yes -in .lms.bts -side right
+    ttk::button .lms.no -text "no" -command \
+      {raise $::lms_parent; destroy .lms; set ::lms_var "no"}
+    ppack .lms.no -in .lms.bts -side right
+  }
+  if {$type eq "yesnocancel" || $type eq "okcancel"} {
+    ttk::button .lms.cancel -text "cancel" -command \
+        {raise $::lms_parent; destroy .lms; set ::lms_var "cancel"}
+    ppack .lms.cancel -in .lms.bts -side right
+  }
+
+  place_wrt .lms $::lms_parent
+  grab set .lms
+  focus .lms
+  tkwait variable ::lms_var
+  return $::lms_var
+} ; # long_message
+
+proc any_message {str type {p "."}} {
+  if {[string length $str] < 400} {
+    if {$type ne "ok"} {
+      return [tk_messageBox -message $str -type $type -parent $p \
+                 -icon question]
+    } else {
+      return [tk_messageBox -message $str -type $type -parent $p]
+    }
+  } else {
+    return [long_message $str $type $p]
+  }
+} ; # any_message
+
 proc make_widgets {} {
 
   wm title . "$::progname $::procid"
-  if $::any_unix {. configure -background $::default_bg}
 
   # width of '0', as a rough estimate of average character width
   set ::cw [font measure TkTextFont "0"]
@@ -916,9 +1009,12 @@ proc make_widgets {} {
       -label "About"
 
   # wallpaper frame
-  # it is possible to set a background color for the parent toplevel,
-  # but on MacOS I did not find a way to determine the right $::default_bg.
-  pack [ttk::frame .bg]
+  # it is possible to set a background color for a toplevel, but on
+  # MacOS I did not find a way to determine the right $::default_bg
+  # color. Instead, all toplevels are given a wallpaper ttk::frame
+  # with the default ttk::frame color, which seems to work
+  # everywhere.
+  pack [ttk::frame .bg] -expand 1 -fill both
 
   # various info
   ttk::frame .topf
@@ -1043,7 +1139,8 @@ proc make_widgets {} {
   grid .pkvsb -in .fpkg -row 0 -column 1 -sticky ns
   grid .pkhsb -in .fpkg -row 1 -column 0 -sticky ew
   grid columnconfigure .fpkg 0 -weight 1
-  pack .fpkg -in .bg -side top -expand 1
+  grid rowconfigure .fpkg 0 -weight 1
+  pack .fpkg -in .bg -side top -fill both -expand 1
 
   # "#1" refers to the first column (with mark symbols)
   bind .pkglist <space> {toggle_marked [.pkglist focus] "#1"}
@@ -1080,7 +1177,7 @@ proc make_widgets {} {
   # log displays: new toplevel, again with themed background frame
   toplevel .lw
   wm title .lw Logs
-  pack [ttk::frame .lw.bg]
+  pack [ttk::frame .lw.bg] -fill both -expand 1
 
   ttk::frame .lw.log
   pack [ttk::scrollbar .lw.log.scroll -command ".lw.log.tx yview"] \
@@ -1133,20 +1230,22 @@ proc repositories {} {
 
   set ::new_repo $::repo
 
-  # look at dialog.tcl how to implement dialog-type behavior
-
   # toplevel with
-  # - list of mirrors (parse tlpkg/installer/ctan-mirrors.pl)
-  # - text entry box, or browser button
+  # - popup menu of mirrors (parse tlpkg/installer/ctan-mirrors.pl)
+  # - text entry box
+  # - directory browser button
   # - ok and cancel buttons
+
+  # look at dialog.tcl how to implement dialog-type behavior
   toplevel .tlr -class Dialog
   wm withdraw .tlr
   wm transient .tlr .
   wm title .tlr "Repositories"
   if $::plain_unix {wm attributes .tlr -type dialog}
-  #if $::any_unix .tlr configure -background $::default_bg
-  pack [ttk::frame .tlr.bg]
-  pack [ttk::frame .tlr.info] -in .tlr.bg
+
+  # wallpaper frame; see make_widgets:
+  pack [ttk::frame .tlr.bg] -expand 1 -fill x
+  pack [ttk::frame .tlr.info] -in .tlr.bg -expand 1 -fill x
   grid columnconfigure .tlr.info 1 -weight 1
   set row -1
 
@@ -1169,7 +1268,7 @@ proc repositories {} {
   ttk::button .tlr.ctan -text "Any CTAN mirror" \
       -command {set ::new_repo "http://mirror.ctan.org/systems/texlive/tlnet"}
   ppack .tlr.ctan -in .tlr.mirbuttons -side left -fill x -expand 1
-  # create a cascading mirror popup menu
+  # freshly create a cascading mirror popup menu
   destroy .tlr.mir.m
   if {[dict size $::mirrors] == 0} read_mirrors
   if {[dict size $::mirrors] > 0} {
@@ -1209,6 +1308,7 @@ proc repositories {} {
   place_wrt .tlr .
   grab set .tlr
   focus .tlr
+  wm resizable .tlr 0 0 ; # .tlr not resizable
 } ; # repositories
 
 proc close_repos {{how ""}} {
@@ -1344,7 +1444,7 @@ proc read_mirrors {} {
   if {! $ok} {do_debug $msg}
 } ; # read_mirrors
 
-proc edit_name {n} {
+proc edit_name {n} { ; # probably unnecessary
   set n [string tolower $n]
   set n [string map {" "  "_"} $n]
   return $n