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

commits+siepo at tug.org commits+siepo at tug.org
Tue Aug 22 16:36:54 CEST 2017


Revision: 45094
          http://tug.org/svn/texlive?view=revision&revision=45094
Author:   siepo
Date:     2017-08-22 16:36:53 +0200 (Tue, 22 Aug 2017)
Log Message:
-----------
Complete local and remote package listings

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-08-22 00:21:26 UTC (rev 45093)
+++ trunk/Master/texmf-dist/scripts/tlshell/tlshell.tcl	2017-08-22 14:36:53 UTC (rev 45094)
@@ -5,17 +5,15 @@
 # - example of doing something with selected database item
 # - restart self
 
-# windows: most scripts run via [w]runscript.
-
-# linux: tlshell.tcl MUST  be run via a symlink in a directory
+# searchpath:
+# windows: most scripts run via [w]runscript, which adjusts the searchpath
+# for the current process.
+# unix/linux: tlshell.tcl should  be run via a symlink in a directory
 # which also contains (a symlink to) kpsewhich.
 # This directory will be prepended to the searchpath.
-# let kpsewhich disentangle symlinks.
+# kpsewhich will disentangle symlinks.
 
-# short wait in case of restart. Would this be useful?
-# after 100
-
-# for security:
+# security: disable send
 catch {rename send {}}
 
 set progname [info script]
@@ -28,13 +26,18 @@
 set err_log {}
 set out_log {}
 
-# pkgs: dict of package dicts
-set pkgs {}
+# dicts of package dicts
+if 0 {
+  set pkgs {}
+}
+set pkgs_local {}
+set pkgs_remote {}
+set pkgs pkgs_local
 
 set prmpt "tlmgr>"
 set busy 0
 
-set ddebug 0
+set ddebug 1
 proc do_debug {s} {
   if {$::ddebug} {
     puts stderr $s
@@ -60,7 +63,9 @@
   return $fname
 }
 
-# TODO: replace messagebox with a custom toplevel with a text widget
+# 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
@@ -99,7 +104,7 @@
     if {[string first $::prmpt $l] == 0} {
       # prompt line: done with command
       read_err
-      set ::busy "IDLE"
+      enable_widgets 1
       $::pipe_cb "finish"
     } else {
       lappend ::out_log $l
@@ -123,17 +128,71 @@
   }
 }
 
-# cb: short for callback (for file events of tlmgr pipe ::tlshl)
+proc selection_popup {sl} {
+  tk_messageBox -message [join $sl "\n"]
+}
 
+# combined display of local and remote package database information
+# in treeview widget
+proc display_packages {} {
+  set pknames {}
+  .pkglist delete [.pkglist children {}]
+  if {[llength $::pkgs_remote] > 0} {
+    set pknames [dict keys $::pkgs_remote]
+    set n [llength $pknames]
+    append mess "\n $n remote packages"
+  }
+  if {[llength [dict keys $::pkgs_local]] > 0} {
+    set n [llength [dict keys $::pkgs_local]]
+    append mess "\n $n local packages"
+    foreach nm [dict keys $::pkgs_local] {
+      lappend pknames $nm
+      do_debug "found $nm"
+    }
+  }
+  if {[llength $pknames] <= 0} {return}
+
+  set pknames [lsort -unique $pknames]
+  foreach nm $pknames {
+    set in_l 0
+    if {[lsearch $::pkgs_local $nm] >= 0} {set in_l 1}
+    set in_r 0
+    if {[lsearch $::pkgs_remote $nm] >= 0} {set in_r 1}
+    set vl [list $nm]
+    if $in_l {
+      lappend vl [dict get $::pkgs_local $nm revision]
+    } else {
+      lappend vl {}
+    }
+    if $in_r {
+      lappend vl [dict get $::pkgs_remote $nm revision]
+    } else {
+      lappend vl {}
+    }
+    if $in_l {
+      lappend vl [dict get $::pkgs_local $nm shortdesc]
+    } else {
+      lappend vl [dict get $::pkgs_remote $nm shortdesc]
+    }
+    .pkglist insert {} end -id $nm -values $vl
+  }
+  update ; # uncomment if necessary
+} ; # display_packages
+
+# callbacks for file events of tlmgr pipe ::tlshl (names *_cb) ###
+
 proc empty_cb {mode {l ""}} {}
 
 set pipe_cb empty_cb
 
 ## template for non-empty pipe callback:
-#proc packages_cb {mode {l ""}} {
+#proc template_cb {mode {l ""}} {
 #  if {$mode eq "line"} {
+#    # do something
 #  } elseif {$mode eq "init"} {
+#    # do something
 #  } elseif {$mode eq "finish"} {
+#    # do something
 #  } else {
 #    lappend ::err_log "Illegal call of whatever_cb"
 #    err_exit
@@ -164,29 +223,53 @@
   }
 } ; # log_widget_cb
 
-proc packages_cb {mode {l ""}} {
+proc dump_db_cb {mode {l ""}} {
+  upvar #0 $::pkgs pk
   if {$mode eq "line"} {
-    # .pkglist configure -state normal
-    set re {^([ i]) ([^: ]+): (.*)$}
-    if {[regexp $re $l m is_inst pname pdescr]} {
-      do_debug "Match: $l"
-      # for now, we assume that there are no duplicates
-      if {$is_inst eq " "} {set is_inst false} else {set is_inst true}
-      dict set ::pkgs $pname {$pdescr $is_inst}
-      .pkglist insert {} end -id $pname -values \
-          [list [expr {$is_inst ? {X} : {}}] $pname $pdescr]
+    if {$l eq ""} {
+      # package records are separated by blank lines
+      set ::cur_pkg ""
+      return
+    } elseif {[string first "name " $l] == 0} {
+      set nm [string range $l 5 end]
+      if {$nm eq ""} {
+        lappend ::err_log "Empty name in database"
+        err_exit
+      }
+      do_debug "package $nm"
+      set ::cur_pkg $nm
+      # initialize package sub-dictionary to empty
+      dict set pk $nm {}
+      # initialize relevant subkeys to empty
+      foreach f {shortdesc category revision} {
+        dict set pk $::cur_pkg $f {}
+      }
+      return
     } else {
-      do_debug "No match: $l"
+      if {$::cur_pkg eq ""} {return}
+      foreach s {category revision shortdesc} {
+        set i [string length $s]
+        incr i
+        if {[string first "$s " $l] == 0} {
+          dict set pk $::cur_pkg  $s [string range $l $i end]
+          return
+        }
+      }
     }
+    # do not process other information
+    return
   } elseif {$mode eq "init"} {
-    foreach k [dict keys $::pkgs] {dict unset ::pkgs $k}
+    set pk {}
+    set ::cur_pkg ""
+    return
   } elseif {$mode eq "finish"} {
-    # fill_package_listbox
+    display_packages
+    return
   } else {
-    lappend ::err_log "Illegal call of packages_cb"
+    lappend ::err_log "Illegal call of dump_db_cb"
     err_exit
   }
-} ; # log_widget_cb
+} ; # dump_db_cb
 
 proc package_popup_cb {mode {l ""}} {
   if {$mode eq "finish"} {
@@ -194,20 +277,48 @@
   }
 }
 
-# running tlmgr ############################################
+# procs involving running tlmgr commands #########################
 
 proc run_cmd {cmd} {
   do_debug "run_cmd \"$cmd\""
+  enable_widgets 0
   set ::out_log {}
   set ::err_log {}
   $::pipe_cb "init"
   chan puts $::tlshl $cmd
   chan flush $::tlshl
-  do_debug "posting busy"
-  set ::busy "BUSY"
   do_debug "puts and flush"
 }
 
+proc run_entry {} {
+  # TODO: some validation of $cmd
+  do_debug "run_entry"
+  set cmd [.ent.e get]
+  if {$cmd eq ""} return
+  do_debug $cmd
+  .ent.e delete 0 end
+  .ent.prv configure -text $cmd
+  .ent.e configure -state disabled
+  set ::pipe_cb log_widget_cb
+  run_cmd $cmd
+}
+
+proc package_popup {it} {
+  # tk_messageBox -message $it
+  set ::pipe_cb package_popup_cb
+  run_cmd "info $it"
+}
+
+# $db should be either local or remote
+proc dump_db {db} {
+  do_debug "reading $db"
+  set ::pkgs pkgs_$db
+  set ::pipe_cb dump_db_cb
+  run_cmd "dump-tlpdb --$db"
+}
+
+# (re)initialization procs ############################
+
 proc start_tlmgr {} {
   # start the TeX Live Manager shell interface
   # capture stdout into the pipe, stderr into a temp file
@@ -218,8 +329,6 @@
   set ::pipe_cb empty_cb
 }
 
-# no more restart of tlmgr only
-
 proc restart_self {} {
   do_debug "trying to restart"
   if {$::progname eq ""} {
@@ -229,34 +338,12 @@
   catch {chan close $::tlshl}
   catch {chan close $::err}
   exec $::progname &
+  # on windows, it may take several seconds before
+  # the old tlshell disappears.
+  # oh well, windows is still windows....
   exit
 }
 
-proc run_entry {} {
-  # TODO: some validation of $cmd
-  do_debug "run_entry"
-  set cmd [.ent.e get]
-  if {$cmd eq ""} return
-  do_debug $cmd
-  .ent.e delete 0 end
-  .ent.prv configure -text $cmd
-  .ent.e configure -state disabled
-  set ::pipe_cb log_widget_cb
-  run_cmd $cmd
-}
-
-proc package_popup {it} {
-  # tk_messageBox -message $it
-  set ::pipe_cb package_popup_cb
-  run_cmd "info $it"
-}
-
-proc view_collections {} {
-  set cmd "info collections"
-  set ::pipe_cb packages_cb
-  run_cmd $cmd
-}
-
 proc make_widgets {} {
 
   wm title . "$::progname $::procid"
@@ -266,10 +353,13 @@
 
   frame .buttons
   grid [label .more -justify left -text "Buttons (more to come)"] \
-      -in .buttons -column 0 -columnspan 2 -row 0 -sticky w
-  grid [ttk::button .collections -text "Show collections" \
-            -command view_collections] \
+      -in .buttons -column 0 -columnspan 3 -row 0 -sticky w
+  grid [ttk::button .locals -text "Show installed packages" \
+            -command {dump_db local}] \
       -in .buttons -column 0 -row 1 -sticky w
+  grid [ttk::button .remotes -text "Show all packages" \
+            -command {dump_db remote}] \
+      -in .buttons -column 1 -row 1 -sticky w
   pack .buttons -side top -fill x -expand 1
 
   # command entry
@@ -288,27 +378,33 @@
   grid columnconfigure .ent 1 -weight 1
   pack .ent -fill x -side top -expand 1
 
-  # packages list (tlmgrgui uses a ptk-specific HList widget)
+  # packages list (tlmgrgui uses an old HList widget)
   frame .fpkg
-  ttk::treeview .pkglist -columns {ins name description} \
-      -show headings -height 8 -selectmode browse \
+  ttk::treeview .pkglist -columns \
+      {name localrev remoterev shortdesc} \
+      -show headings -height 8 -selectmode extended \
       -xscrollcommand {.pkhsb set} -yscrollcommand {.pkvsb set}
-  foreach col {ins name description} nm {{Inst.} Name Description} {
+  foreach \
+      col {name localrev remoterev shortdesc} \
+      nm {Name "Local Rev." "Remote Rev." Description} {
     .pkglist heading $col -text $nm -anchor w
   }
-  .pkglist column ins -width [expr $cw * 5]
   .pkglist column name -width [expr $cw * 25]
-  .pkglist column description -width [expr $cw * 50]
+  .pkglist column localrev -width [expr $cw * 10]
+  .pkglist column remoterev -width [expr $cw * 10]
+  .pkglist column shortdesc -width [expr $cw * 50]
+
   ttk::scrollbar .pkhsb -orient horizontal -command {.pkglist xview}
   ttk::scrollbar .pkvsb -orient vertical -command {.pkglist yview}
   grid .pkglist -in .fpkg -row 0 -column 0 -sticky news
   grid .pkvsb -in .fpkg -row 0 -column 1 -sticky ns
   grid .pkhsb -in .fpkg -row 1 -column 0 -sticky ew
-  grid columnconfigure .fpkg 2 -weight 1
+  grid columnconfigure .fpkg 0 -weight 1
   pack .fpkg -side top -expand 1
   bind .pkglist <ButtonRelease> {package_popup [.pkglist identify item %x %y]}
-  bind .pkglist <space> {package_popup [.pkglist selection]}
-  bind .pkglist <Return> {package_popup [.pkglist selection]}
+  # focus or selection?
+  bind .pkglist <space> {package_popup [.pkglist focus]}
+  bind .pkglist <Return> {selection_popup [.pkglist selection]}
 
   # log displays
   frame .log
@@ -338,13 +434,42 @@
   frame .endbuttons
   pack [ttk::button .q -text Quit -command exit] \
       -in .endbuttons -side right
-  # pack [ttk::button .r -text "Restart tlmgr" -command restart_tlmgr] \
-  #     -in .endbuttons -side right
-  pack [ttk::button .s -text "Restart self" -command restart_self] \
+  pack [ttk::button .r -text "Restart self" -command restart_self] \
       -in .endbuttons -side right
   pack .endbuttons -side bottom -fill x -expand 1
 } ; # make_widgets
 
+proc enable_widgets {yesno} {
+  if $yesno {
+    set st normal
+    set ttk_st !disabled
+    set ::busy "IDLE"
+  } else {
+    set st disabled
+    set ttk_st disabled
+    set ::busy "BUSY"
+  }
+  # buttons
+  .locals configure -state $ttk_st
+  .remotes configure -state $ttk_st
+  # command entry
+  .ent.b configure -state $st
+  .ent.e configure -state $st
+  # package list
+  if $yesno {
+    .pkglist configure -takefocus 1
+    bind .pkglist <ButtonRelease> \
+        {package_popup [.pkglist identify item %x %y]}
+  } else {
+    .pkglist configure -takefocus 0
+    bind .pkglist <ButtonRelease> {}
+  }
+  # do not touch the log windows
+  # final buttons
+  .q configure -state $ttk_st
+  .r configure -state $ttk_st
+} ; # enable_widgets
+
 proc initialize {} {
   # prepend TL to process searchpath (not needed on windows)
   if {$::tcl_platform(platform) ne "windows"} {



More information about the tex-live-commits mailing list