texlive[46058] Master/texmf-dist/scripts/tlshell/tlshell.tcl:

commits+siepo at tug.org commits+siepo at tug.org
Wed Dec 13 11:59:10 CET 2017


Revision: 46058
          http://tug.org/svn/texlive?view=revision&revision=46058
Author:   siepo
Date:     2017-12-13 11:59:09 +0100 (Wed, 13 Dec 2017)
Log Message:
-----------
Install, remove and update single and marked packages

Modified Paths:
--------------
    trunk/Master/texmf-dist/scripts/tlshell/tlshell.tcl

Modified: trunk/Master/texmf-dist/scripts/tlshell/tlshell.tcl
===================================================================
--- trunk/Master/texmf-dist/scripts/tlshell/tlshell.tcl	2017-12-13 01:22:30 UTC (rev 46057)
+++ trunk/Master/texmf-dist/scripts/tlshell/tlshell.tcl	2017-12-13 10:59:09 UTC (rev 46058)
@@ -468,7 +468,7 @@
   display_packages_info
 } ; # collect_filtered
 
-# display packages obeying filter and search string.
+# display packages obeying both filter and search string.
 # even on a relatively slow system, regenerating the entire list
 # at every keystroke is acceptably responsive.
 # with future more advanced search options, this scheme may not suffice.
@@ -615,6 +615,194 @@
   collect_filtered
 } ; # update_all
 
+### doing something with some packages
+
+proc pkgs_option {opt {nm ""}} {
+  if {$opt eq "marked"} {
+    set pks {}
+    dict for {p props} $::pkgs {
+      if [dict get $props "marked"] {lappend pks $p}
+    }
+  } elseif {$opt eq "focus"} {
+    set p [.pkglist focus]
+    if {$p ne {}} {lappend pks $p}
+  } elseif {$opt eq "name"} {
+    lappend pks $nm
+  }
+  return $pks
+} ; # pkgs_option
+
+proc after_package_changes {} {
+  update_local_revnumbers
+  collect_filtered
+  wm state .lw normal
+  place_wrt .lw .
+} ; # after_package_changes
+
+proc install_pkgs {sel_opt {pk ""}} {
+  set pks [pkgs_option $sel_opt $pk]
+  # check whether packages are installed
+  set pre_installed {}
+  set todo {}
+  foreach p $pks {
+    if {[dict get $::pkgs $p localrev] > 0} {
+      lappend pre_installed $p
+    } else {
+      lappend todo $p
+    }
+  }
+  if {[llength $todo] == 0} {
+    tk_messageBox -message "Nothing to do!" -type ok -icon info
+    return
+  }
+  run_cmd_waiting "install --dry-run $todo"
+  # check whether dependencies are going to be installed
+  set r {^(\S+)\s+i\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 [tk_messageBox -message \
+             "Also installing dependencies $deps.\nContinue?" \
+                 -type yesno -icon question]
+    if {$ans eq "cancel"} return
+  }
+  run_cmd "install $todo" log_widget_cb
+  vwait ::done_waiting
+  if {[llength $pre_installed] > 0} {
+    lappend ::err_log "Already installed: $pre_installed"
+    show_err_log
+  }
+  after_package_changes
+} ; # install_pkgs
+
+proc update_pkgs {sel_opt {pk ""}} {
+  set pks [pkgs_option $sel_opt $pk]
+  # check whether packages are installed
+  set not_inst {}
+  set uptodate {}
+  set todo {}
+  foreach p $pks {
+    set lv [dict get $::pkgs $p localrev]
+    if {[dict get $::pkgs $p localrev] == 0} {
+      lappend not_inst $p
+    } else {
+      set rv [dict get $::pkgs $p remoterev]
+      if {$lv >= $rv} {
+        lappend uptodate $p
+      } else {
+        lappend todo $p
+      }
+    }
+  }
+  if {[llength $todo] == 0} {
+    tk_messageBox -message "Nothing to do!" -type ok -icon info
+    return
+  }
+  run_cmd "update $todo" log_widget_cb
+  vwait ::done_waiting
+  if {[llength $not_inst] > 0} {
+    lappend ::err_log "Skipped because not installed: $not_inst"
+  }
+  if {[llength $uptodate] > 0} {
+    lappend ::err_log "Skipped because already up to date: $uptodate"
+  }
+  if {[llength $not_inst] > 0 || [llength $uptodate] > 0} {
+    show_err_log
+  }
+  after_package_changes
+} ; # update_pkgs
+
+proc remove_pkgs {sel_opt {pk ""}} {
+  set pks [pkgs_option $sel_opt $pk]
+  # check whether packages are installed
+  set not_inst {}
+  set todo {}
+  foreach p $pks {
+    if {[dict get $::pkgs $p localrev] > 0} {
+      lappend todo $p
+    } else {
+      lappend not_inst $p
+    }
+  }
+  run_cmd_waiting "remove --dry-run $todo"
+  # check whether dependencies are going to be removed
+  set r {^(\S+)\s+d\s}
+  set deps {}
+  foreach l $::out_log {
+    if {[regexp $r $l d p] && $p ni $pks} {
+      lappend deps $p
+    }
+  }
+  if {[llength $todo] == 0} {
+    tk_messageBox -message "Nothing to do!" -type ok -icon info
+    return
+  }
+  if {[llength $deps] > 0} {
+    set ans [tk_messageBox -message \
+             "Also remove dependencies $deps?" \
+                 -type yesnocancel -icon question]
+    switch $ans {
+      "cancel" return
+      "yes" {run_cmd "remove $todo" log_widget_cb}
+      "no" {run_cmd "remove --no-depends $todo" log_widget_cb}
+    }
+  } else {
+    run_cmd "remove $todo" log_widget_cb
+  }
+  vwait ::done_waiting
+ if {[llength $not_inst] > 0} {
+    lappend ::err_log "Skipped because not installed: $not_inst"
+    show_err_log
+  }
+  after_package_changes
+} ; # remove_pkgs
+
+#proc restore_pkgs {sel_opt {pk ""}} {
+#} ; # restore_pkgs # not yet
+
+## 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]
+  # recreate menu with only applicable items
+  set lr [dict get $::pkgs [.pkglist focus] "localrev"]
+  set rr [dict get $::pkgs [.pkglist focus] "remoterev"]
+  .pkg_popup delete 0 end
+  .pkg_popup add command -label "Info" -command \
+      {run_cmd "info [.pkglist focus]" log_widget_cb; \
+           vwait ::done_waiting}
+  if {$::have_remote && ! $::need_update_tlmgr && $rr > 0 && $lr == 0} {
+    .pkg_popup add command -label "Install" -command \
+        {install_pkgs "focus"}
+  }
+  if {$::have_remote && ! $::need_update_tlmgr && $lr > 0 && $rr > $lr} {
+    .pkg_popup add command -label "Update" -command \
+        {update_pkgs "focus"}
+  }
+  if {$lr > 0} {
+    .pkg_popup add command -label "Remove" -command \
+        {remove_pkgs "focus"}
+  }
+  .pkg_popup post $X $Y
+  focus .pkg_popup
+} ; # do_package_popup
+
 ##### building GUI #####
 
 # dummy widgets for vertical spacing within $w
@@ -696,13 +884,13 @@
     # 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
+    # 'tk appname <something>' restores 'send' and avoids the bug
     bind . <Destroy> {
       catch {tk appname appname}
     }
   }
 
-  .mn add cascade -label File -menu .mn.file -underline 0
+  .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}
@@ -710,20 +898,28 @@
       -command repositories
   .mn.file add command -command {destroy .} -label "Exit" -underline 1
 
-  .mn add cascade -label Options -menu .mn.opt -underline 0
+  .mn add cascade -label "Options" -menu .mn.opt -underline 0
   menu .mn.opt
 
-  .mn add cascade -label Actions -menu .mn.act -underline 0
+  .mn add cascade -label "Actions" -menu .mn.act -underline 0
   menu .mn.act
+  .mn.act add command -label "Install marked" \
+      -command {install_pkgs "marked"}
+  .mn.act add command -label "Update marked" \
+      -command {update_pkgs "marked"}
+  .mn.act add command -label "Remove marked" \
+      -command {remove_pkgs "marked"}
 
-  .mn add cascade -label Help -menu .mn.help -underline 0
+  .mn add cascade -label "Help" -menu .mn.help -underline 0
   menu .mn.help
   .mn.help add command -command {tk_messageBox -message "Helpless"} \
       -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]
-  
+
   # various info
   ttk::frame .topf
 
@@ -923,53 +1119,14 @@
   raise .lw.log .lw.logs
   pack .lw.logs -in .lw.bg -side top -fill both -expand 1
 
-  ttk::frame .lw.bottom
+  pack [ttk::frame .lw.bottom] -in .lw.bg -side top -expand 1 -fill x
   ttk::button .lw.close -text close -command {wm withdraw .lw}
   ppack .lw.close -in .lw.bottom -side right -anchor e
   ppack [ttk::label .lw.status -anchor w] -in .lw.bottom -side left
-  pack .lw.bottom -in .lw.bg -side top -expand 1 -fill x
 
   wm withdraw .lw
 } ; # make_widgets
 
-## 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]
-  # recreate menu with only applicable items
-  set lr [dict get $::pkgs [.pkglist focus] "localrev"]
-  set rr [dict get $::pkgs [.pkglist focus] "remoterev"]
-  .pkg_popup delete 0 end
-  .pkg_popup add command -label "Info" -command \
-      {run_package_cmd "info"}
-  if {$::have_remote && ! $::need_update_tlmgr && $rr > 0 && $lr == 0} {
-    .pkg_popup add command -label "Install" -command \
-        {run_package_cmd "install" 1}
-  }
-  if {$::have_remote && ! $::need_update_tlmgr && $rr > $lr} {
-    .pkg_popup add command -label "Update" -command \
-        {run_package_cmd "update" 1}
-  }
-  if {$lr > 0} {
-    .pkg_popup add command -label "Remove" -command \
-        {run_package_cmd "remove" 1}
-  }
-  .pkg_popup post $X $Y
-  focus .pkg_popup
-} ; # do_package_popup
-
 ### repositories
 
 proc repositories {} {
@@ -1058,7 +1215,6 @@
   raise .
   destroy .tlr
   if {$how eq "save"} {
-  # the alternative
     set ::repo $::new_repo
     if {$::tcl_platform(platform) eq "windows"} {
       set ::repo [string map {\\ /} $::repo]
@@ -1072,7 +1228,7 @@
     get_packages_info_remote
     collect_filtered
   }
-}
+} ; # close_repos
 
 proc find_local_repo {} {
   if [is_repo_local $::new_repo] {
@@ -1186,19 +1342,6 @@
   }
   close $fm
   if {! $ok} {do_debug $msg}
-  # relocate Australia and New Zealand if they are
-  # classified under North America
-  dict set ::mirrors "Other" [dict create]
-  set dict_nam [dict get $::mirrors "North America"]
-  foreach c {"Australia" "New Zealand"} {
-    if [dict exists $dict_nam $c] {
-      dict set ::mirrors "Other" $c [dict get $dict_nam $c]
-      dict unset ::mirrors "North America" $c
-    }
-  }
-  if {[dict size [dict get $::mirrors "Other"]] == 0} {
-    dict unset ::mirrors "Other"
-  }
 } ; # read_mirrors
 
 proc edit_name {n} {
@@ -1272,7 +1415,7 @@
   chan configure $::tlshl -buffering line -blocking 0
   chan event $::tlshl readable read_line
   vwait ::done_waiting
-}
+} ; # start_tlmgr
 
 proc close_tlmgr {} {
   catch {chan close $::tlshl}
@@ -1279,11 +1422,6 @@
   catch {chan close $::err}
 }
 
-proc change_repo {} {
-  run_cmd_waiting "option repository $::repo"
-  get_packages_info_remote
-}
-
 proc restart_self {} {
   do_debug "trying to restart"
   if {$::progname eq ""} {



More information about the tex-live-commits mailing list