texlive[45354] Master/texmf-dist/scripts/tlshell/tlshell.tcl: Some
commits+siepo at tug.org
commits+siepo at tug.org
Wed Sep 20 22:20:56 CEST 2017
Revision: 45354
http://tug.org/svn/texlive?view=revision&revision=45354
Author: siepo
Date: 2017-09-20 22:20:55 +0200 (Wed, 20 Sep 2017)
Log Message:
-----------
Some installation options implemented, new proc run_cmd_waiting, fewer globals
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-09-20 10:22:59 UTC (rev 45353)
+++ trunk/Master/texmf-dist/scripts/tlshell/tlshell.tcl 2017-09-20 20:20:55 UTC (rev 45354)
@@ -15,6 +15,8 @@
# This directory will be prepended to the searchpath.
# kpsewhich will disentangle symlinks.
+##### general housekeeping #####
+
# security: disable send
catch {rename send {}}
@@ -27,7 +29,7 @@
}
}
-proc get_stack {} {
+proc get_stacktrace {} {
set level [info level]
set s ""
for {set i 1} {$i < $level} {incr i} {
@@ -36,80 +38,53 @@
return $s
}
-# unicode characters as tag indicators, in hex. This is pretty safe,
-# since Tk will use glyphs from other fonts if necessary.
-# With bitmaps, we would have to worry about HiDpi displays.
+proc maketemp {ext} {
+ set fname ""
+ foreach i {0 1 2 3 4 5 6 7 8 9} { ; # ten tries
+ set fname [file join $::tempsub "[expr int(10000.0*rand())]$ext"]
+ if {[file exist $fname]} {set fname ""; continue}
+ # create empty file. although we just want a name,
+ # we must make sure that it can be created.
+ set fid [open $fname w]
+ close $fid
+ if {! [file exists $fname]} {error "Cannot create temporary file"}
+ if {$::tcl_platform(platform) eq "unix"} {
+ file attributes $fname -permissions 0600
+ }
+ break
+ }
+ if {$fname eq ""} {error "Cannot create temporary file"}
+ return $fname
+} ; # maketemp
-set mrk [format %c 0x25a3] ; # 'white square containing black small square'
-set nomrk [format %c 0x25a1] ; # 'white square'
+set tempsub "" ; # subdir for temp files, set during initialization
+##### tl global status variables #####
+
set progname [info script]
regexp {^.*[\\/]([^\\/\.]*)(?:\....)?$} $progname dummy progname
set procid [pid]
-set tempsub "" ; # subdirectory for temporary files
+# package repository
+set repo ""
# the stderr and stdout of tlmgr are each read into a list of strings
set err_log {}
set out_log {}
-# callback for reading tlmgr pipe
-set pipe_cb ""
-set lnum -1
-
# dict of (local and global) package dicts
set pkgs [dict create]
-set do_remote 0 ; # get local packages
-set have_remote 0 ; # remote packages loaded
+set have_remote 0 ; # remote packages info loaded
+set need_update_self 0
+set n_updates 0
+set tlshell_updatable 0
-# filtering the package list, parameter should be package NAME
-set filt ""
+##### handling tlmgr via pipe and stderr tempfile #####
-proc filt_local {p} {
- return [dict get $::pkgs $p localrev]
-}
-
-proc filt_collections {p} {
- set c [dict get $::pkgs $p "category"]
- return [expr \"$c\" eq \"Collection\"]
-}
-
-proc filt_upgradable {p} {
- do_debug "Is $p upgradable?"
- set lr [dict get $::pkgs $p localrev]
- set rr [dict get $::pkgs $p remoterev]
- do_debug "$p: comparing $lr and $rr"
- if {$lr == 0} {
- return 0
- } elseif {$rr == 0} {
- return 0
- }
- return [expr $rr > $lr]
-}
-
set prmpt "tlmgr>"
set busy 0
-proc maketemp {ext} {
- set fname ""
- foreach i {0 1 2 3 4 5 6 7 8 9} { ; # ten tries
- set fname [file join $::tempsub "[expr int(10000.0*rand())]$ext"]
- if {[file exist $fname]} {set fname ""; continue}
- # create empty file. although we just want a name,
- # we must make sure that it can be created.
- set fid [open $fname w]
- close $fid
- if {! [file exists $fname]} {error "Cannot create temporary file"}
- if {$::tcl_platform(platform) eq "unix"} {
- file attributes $fname -permissions 0600
- }
- break
- }
- if {$fname eq ""} {error "Cannot create temporary file"}
- return $fname
-}
-
# TODO:
# replace messagebox with a custom toplevel with a text widget
# in case there is a lot of text
@@ -134,11 +109,13 @@
}
# about [chan] gets:
-# if a second parameter is supplied
+# if a second parameter, in this case l, is supplied
# then this variable receives the result, with EOL stripped,
# and the return value is the string length, possibly 0
# EOF is indicated by a return value of -1.
+# a caller of run_cmd needs to explicitly invoke 'vwait ::done_waiting'
+# if it wants to wait for the command to finish
proc read_line {} {
incr ::lnum
set l "" ; # will contain the line to be read
@@ -149,14 +126,16 @@
# note. the right way to terminate is terminating the shell
} elseif {$len >= 0} {
# do_debug "read: $l"
+ if $::ddebug {puts $::flid $l}
if {[string first $::prmpt $l] == 0} {
# prompt line: done with command
- enable_widgets 1
+ enable_widgets 1 ; # this may have to be redone later
read_err
if {$::pipe_cb ne ""} {
do_debug "$::lnum: prompt found, $l"
$::pipe_cb "finish"
}
+ set ::done_waiting 1
} else {
lappend ::out_log $l
if {$::pipe_cb ne ""} {$::pipe_cb "line" "$l"}
@@ -164,7 +143,11 @@
}
} ; # read_line
-# copy error strings to error page, which is sent to top.
+##### displaying stuff in GUI #####
+
+## stderr ##
+
+# copy error strings to error log page, which is sent to top.
# This by itself does not map the logs toplevel .lw
proc show_err_log {} {
#do_debug "show_err_log"
@@ -181,59 +164,12 @@
}
} ; # show_err_log
-# package info popup for the package having focus
-proc popup_focused {itm} {
- run_cmd "info $itm" package_popup_cb
-}
+##### callbacks for file events of tlmgr pipe ::tlshl (names *_cb) #####
-# display packages: always display both local and remote revision columns.
-# the caller should have set a filter for the packages to be displayed.
-# ::pkgs should already be up to date
+# callback for reading tlmgr pipe
+set pipe_cb ""
+set lnum -1
-proc display_packages {} {
-
- .pkglist delete [.pkglist children {}]
-
- dict for {nm pk} $::pkgs {
- if {$::filt eq "" || [$::filt $nm]} {
- set vl [list $::nomrk $nm]
- foreach k {localrev remoterev shortdesc} {
- set vv [dict get $pk $k]
- if {$vv eq "0" || $vv == 0} {set vv ""}
- lappend vl $vv
- }
- .pkglist insert {} end -id $nm -values $vl
- } ; # else do not display
- }
- update ; # uncomment if necessary
-} ; # display_packages
-
-##### selection tags in package list ############################
-
-# 1. selections themselves get lost too easily
-# 2. the -image option for ttk::treeview tags does not look right
-# Therefore a do-it-yourself implementation with column #1 reserved for
-# a marker, package name in column #2, and column #0 not displayed.
-# the marker could have been prefixed to the package name in column #0,
-# but I think a separate marker column is a cleaner solution.
-
-proc toggle_marked {itm cl} {
- # if toggle_marked is triggered by a mouse click
- # then it should do nothing unless it was a click in column #1
- if {$cl ne "#1"} {
- return
- }
- if [.pkglist tag has marked $itm] {
- .pkglist tag remove marked $itm
- .pkglist set $itm mk $::nomrk
- } else {
- .pkglist tag add marked $itm
- .pkglist set $itm mk $::mrk
- }
-} ; # toggle_marked
-
-##### callbacks for file events of tlmgr pipe ::tlshl (names *_cb) #####
-
## template for pipe callback:
#proc template_cb {mode {l ""}} {
# if {$mode eq "line"} {
@@ -241,7 +177,7 @@
# } elseif {$mode eq "init"} {
# # do something
# } elseif {$mode eq "finish"} {
-# # do something
+# # do something BUT DO NOT TRIGGER ANOTHER EVENT LOOP
# } else {
# lappend ::err_log "Illegal call of whatever_cb"
# err_exit
@@ -248,13 +184,6 @@
# }
#}
-proc early_cb {mode {l ""}} {
- # for reading initial output tlmgr
- if {$mode eq "finish"} {
- set ::started 1
- }
-}
-
proc log_widget_cb {mode {l ""}} {
if {$mode eq "line"} {
.lw.log.tx configure -state normal
@@ -262,6 +191,9 @@
} elseif {$mode eq "init"} {
.lw.log.tx configure -state normal
.lw.log.tx delete 1.0 end
+ .lw.status configure -text "Running"
+ .lw.close configure -state disabled
+ wm state .lw normal
} elseif {$mode eq "finish"} {
.lw.log.tx yview moveto 1
.lw.logs select .lw.log
@@ -270,7 +202,8 @@
if {$::tcl_platform(os) ne "Darwin"} {
.lw.log.tx configure -state disabled
}
- .ent.e configure -state normal
+ .lw.status configure -text ""
+ .lw.close configure -state !disabled
} else {
lappend ::err_log "Illegal call of log_widget_cb"
err_exit
@@ -277,68 +210,30 @@
}
} ; # log_widget_cb
-proc packages_cb {mode {l ""}} {
- if $::do_remote {
- set re {^([^,]+),([0-9]+),([0-9]+),([^,]*),(.*)$}
- } else {
- set re {^([^,]+),([0-9]+),([^,]*),(.*)$}
- }
- if {$mode eq "line"} {
- #do_debug $l
- if {($::do_remote && [regexp $re $l m pname lrev rrev catg pdescr]) || \
- ((! $::do_remote) && [regexp $re $l m pname lrev catg pdescr])} {
- # unknown revision: 0 in database, " " in displayed list
- if {! $::do_remote} {set rrev 0}
- # double-quotes: remove outer, unescape inner
- if {[string index $pdescr 0] eq "\""} {
- set pdescr [string range $pdescr 1 end-1]
- }
- set pdescr [regsub -all "\\\"" $pdescr "\""]
- dict set ::pkgs $pname \
- [list "localrev" $lrev "remoterev" $rrev \
- "category" $catg shortdesc $pdescr]
- } else {
- #do_debug "$::lnum no match: $l"
- }
- return
- } elseif {$mode eq "init"} {
- # is it useful to remove items one by one?
- # or will the garbage collector take care of it?
- foreach nm [dict keys $::pkgs] {dict unset ::pkgs $nm}
- do_debug "packages_cb init with do_remote $::do_remote and filt $::filt"
- return
- } elseif {$mode eq "finish"} {
- do_debug "packages_cb finish with do_remote $::do_remote and filt $::filt"
- set ::have_remote $::do_remote
- #do_debug [get_stack]
- display_packages
- return
- } else {
- lappend ::err_log "Illegal call of packages_cb"
- err_exit
- }
-} ; # packages_cb
+##### running tlmgr commands #####
-proc package_popup_cb {mode {l ""}} {
- if {$mode eq "finish"} {
- tk_messageBox -message [join $::out_log "\n"]
- }
-}
+## general and various:
-# procs involving running tlmgr commands #########################
-
proc run_cmd {cmd {cb ""}} {
set ::pipe_cb $cb
do_debug "run_cmd \"$cmd\""
+ if $::ddebug {puts $::flid "\n$cmd"}
+ .topf.lcmd configure -text $cmd
enable_widgets 0
set ::out_log {}
set ::err_log {}
set ::lnum 0
+ unset -nocomplain ::done_waiting
if {$::pipe_cb ne ""} {$::pipe_cb "init"}
chan puts $::tlshl $cmd
chan flush $::tlshl
}
+proc run_cmd_waiting {cmd} {
+ run_cmd $cmd ; # "waiting_cb"
+ vwait ::done_waiting
+}
+
proc run_entry {} {
# TODO: some validation of $cmd
do_debug "run_entry"
@@ -350,106 +245,160 @@
run_cmd $cmd log_widget_cb
}
+proc get_repo {} {
+ run_cmd_waiting "option repository"
+ set re {repository\t(.*)$}
+ foreach l $::out_log {
+ if [regexp $re $l m ::repo] break
+ }
+} ; # get_repo
+
+## package-related:
+
proc package_popup {itm} {
- # tk_messageBox -message $itm
- run_cmd "info $itm" package_popup_cb
+ run_cmd_waiting "info $itm"
+ tk_messageBox -message [join $::out_log "\n"]
}
-# package list; use previously set values for ::do_remote and ::filt
-# we already know that we need a package list from tlmgr
-proc get_and_display_packages {} {
- do_debug "get_and_display_packages: filt $::filt and remote $::do_remote"
- foreach k [dict keys $::pkgs] {dict unset ::pkgs $k}
- set ::have_remote 0
- if {$::do_remote} {
- run_cmd "info --data name,localrev,remoterev,category,shortdesc" \
- packages_cb
- } else {
- set ::have_remote 0
- run_cmd "info --only-installed --data name,localrev,category,shortdesc" \
- packages_cb
+proc check_tlmgr_updatable {} {
+ run_cmd_waiting "update --self --list"
+ foreach l $::out_log {
+ if [regexp {^total-bytes[ \t]+([0-9]+)$} $l m b] {
+ do_debug "matches, $b"
+ set ::need_update_self [expr {$b > 0} ? 1 : 0]
+ return
+ }
}
+ do_debug "check_tlmgr_uptodate: should not get here"
+} ; # check_tlmgr_uptodate
+
+proc update_globals {} {
+ if {! $::have_remote} return
+ set ::n_updates 0
+ foreach nm [dict keys $::pkgs] {
+ if [is_updatable $nm] {incr ::n_updates}
+ }
+ check_tlmgr_updatable
+ set ::tlshell_updatable [is_updatable tlshell]
}
-proc show_all_packages {} {
- set ::filt ""
- if $::have_remote {
- display_packages
- } else {
- set ::do_remote 1
- get_and_display_packages ; # calls display_packages as finish callback
+# get fresh package list
+# some local packages may not be available online.
+# to test, create local dual-platform installation from dvd, try to update
+# from more recent linux-only installation
+
+# local: start from scratch
+proc get_packages_info_local {} {
+ foreach nm [dict keys $::pkgs] {
+ dict unset ::pkgs $nm
}
-} ; # show_all_packages
+ set ::have_remote 0
+ set ::need_update_self 0
+ set ::updatable 0
+ set ::tlshell_updatable 0
-proc show_local_packages {} {
- set ::filt filt_local
- set ::do_remote 0
- if {[llength [dict keys $::pkgs]] == 0} {
- do_debug "show_local_packages: no packages loaded"
- set ::have_remote 0
- get_and_display_packages
- } else {
- do_debug "show_local_packages: packages already loaded"
- display_packages
+ run_cmd_waiting \
+ "info --only-installed --data name,localrev,category,shortdesc"
+ set re {^([^,]+),([0-9]+),([^,]*),(.*)$}
+ foreach l $::out_log {
+ if [regexp $re $l m nm lrev catg pdescr] {
+ # double-quotes: remove outer, unescape inner
+ if {[string index $pdescr 0] eq "\""} {
+ set pdescr [string range $pdescr 1 end-1]
+ }
+ set pdescr [regsub -all "\\\"" $pdescr "\""]
+ dict set ::pkgs $nm \
+ [list "localrev" $lrev "remoterev" 0 \
+ "category" $catg shortdesc $pdescr]
+ }
}
-} ; # show_local_packages
+} ; # get_packages_info_local
-proc show_collections {} {
- set ::filt filt_collections
- if {! $::have_remote} {
- set ::do_remote 1
- get_and_display_packages
- } else {
- display_packages
+# remote: preserve information on installed packages
+proc get_packages_info_remote {} {
+ # remove non-local database entries
+ foreach k [dict keys $::pkgs] {
+ if {! [dict get $::pkgs $k localrev]} {
+ dict unset ::pkgs $k
+ }
}
-} ; # show_collections
+ set ::need_update_self 0
+ set ::updatable 0
+ set ::tlshell_updatable 0
-proc show_upgradable {} {
- set ::filt filt_upgradable
- if {! $::have_remote} {
- # get a complete package list
- set ::do_remote 1
- do_debug "show_upgradable: remote not yet loaded"
- get_and_display_packages
- } else {
- do_debug "show_upgradable: remote already loaded"
- display_packages
+ run_cmd_waiting "info --data name,localrev,remoterev,category,shortdesc"
+ set re {^([^,]+),([0-9]+),([0-9]+),([^,]*),(.*)$}
+ foreach l $::out_log {
+ if [regexp $re $l m nm lrev rrev catg pdescr] {
+ # double-quotes in short description: remove outer, unescape inner
+ if {[string index $pdescr 0] eq "\""} {
+ set pdescr [string range $pdescr 1 end-1]
+ }
+ set pdescr [regsub -all "\\\"" $pdescr "\""]
+ if [catch {dict get $::pkgs $nm} pk] {
+ # package entry does not exist
+ dict set ::pkgs $nm [dict create "localrev" 0 \
+ "remoterev" $rrev "category" $catg shortdesc $pdescr]
+ } else {
+ dict set ::pkgs $nm "remoterev" $rrev
+ dict set ::pkgs $nm "category" $catg
+ dict set ::pkgs $nm "shortdesc" $pdescr
+ }
+ }
}
-} ; # show_upgradable
+ set ::have_remote 1
+ update_globals
+} ; # get_packages_info_remote
-# (re)initialization procs ############################
+## update ::pkgs after installing packages without going online.
+## this should be considered a shortcut version of get_packages_info_xxx,
+## and should similarly take care of the globals; see above
+proc update_local_revnumbers {} {
+ run_cmd_waiting "info --only-installed --data name,localrev"
+ set re {^([^,]+),([0-9]+)$}
+ foreach nm [dict keys $::pkgs] {
+ dict set ::pkgs $nm "localrev" 0
+ }
+ foreach l $::out_log {
+ if [regexp $re $l m nm lr] {
+ dict set ::pkgs $nm "localrev" $lr
+ }
+ }
+ update_globals
+} ; # update_local_revnumbers
-proc start_tlmgr {} {
- # start the TeX Live Manager shell interface
- # capture stdout into the pipe, stderr into a temp file
- # below, early_cb and vwait ::started together forces tlshell
- # to process initial tlmgr output before continuing
- set ::pipe_cb early_cb
- unset -nocomplain ::started
- set ::tlshl [open "|tlmgr --machine-readable shell 2>>$::err_file" w+]
- set ::err [open $::err_file r]
- chan configure $::tlshl -buffering line -blocking 0
- chan event $::tlshl readable read_line
- vwait ::started
- show_local_packages
-}
+proc update_self {} {
+ if {! $::need_update_self} {
+ tk_messageBox -message "Nothing to do!"
+ return
+ }
+ run_cmd "update --self" log_widget_cb
+ vwait ::done_waiting
+ # tlmgr restarts itself automatically, reload remote
+ get_packages_info_remote
+ set ::sel_opt "inst"
+ display_packages_info is_local
+} ; # update_self
-proc restart_self {} {
- do_debug "trying to restart"
- if {$::progname eq ""} {
- tk_messageBox -message "progname not found; not restarting"
+proc update_all {} {
+ if $::need_update_self {
+ tk_messageBox -message "Update self first!"
return
+ } elseif {! $::n_updates} {
+ tk_messageBox -message "Nothing to do!"
+ return
}
- 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
-}
+ run_cmd "update --all" log_widget_cb
+ vwait ::done_waiting
+ #wm withdraw .lw
+ update_local_revnumbers
+ set ::sel_opt "inst"
+ display_packages_info is_local
+} ; # update_all
-# dummy widgets for vertical spacing
+##### building GUI #####
+
+# dummy widgets for vertical spacing within $w
set idummy -1
proc spacing {w} {
incr ::idummy
@@ -456,57 +405,82 @@
pack [label $w.$::idummy -text " "]
}
-#proc pgrid {wdg args} { ; # padded grid
-# set l [list grid $wdg -padx 3 -pady 3]
-# foreach v $args {lappend l $v}
-# eval [join $l ""]
-#}
+proc pgrid {wdg args} { ; # grid command with padding
+ set l [list grid $wdg -padx 3 -pady 3 -sticky w]
+ foreach v $args {lappend l $v}
+ eval [join $l " "]
+}
+proc ppack {wdg args} { ; # pack command with padding
+ set l [list pack $wdg -padx 3 -pady 3]
+ foreach v $args {lappend l $v}
+ eval [join $l " "]
+}
+
proc make_widgets {} {
wm title . "$::progname $::procid"
- # width of '0', as a rough estimate of character width
+ # width of '0', as a rough estimate of average character width
set cw [font measure TkTextFont "0"]
# various info
frame .topf
- pack [label .busy -textvariable ::busy] -in .topf -side right -padx 3
- pack [label .more -justify left -text "Buttons (more to come)"] \
- -in .topf -side left -padx 3
- pack .topf -side top -fill x -expand 1
- # main buttons block
- frame .buttons
- grid [ttk::button .pkgl -text "Show all packages" \
- -command show_all_packages] \
- -in .buttons -column 0 -row 1 -sticky w -padx 3 -pady 3
- grid [ttk::button .locals -text "Show installed packages" \
- -command {show_local_packages}] \
- -in .buttons -column 1 -row 1 -sticky w -padx 3 -pady 3
- grid [ttk::button .coll -text "Show collections" \
- -command {show_collections}] \
- -in .buttons -column 2 -row 1 -sticky w -padx 3 -pady 3
- grid [ttk::button .upgr -text "Show upgradable" \
- -command {show_upgradable}] \
- -in .buttons -column 3 -row 1 -sticky w
- pack .buttons -side top -fill x -expand 1 -padx 3 -pady 3
+ pgrid [label .topf.llrepo -text Repository -anchor w] -row 0 -column 0
+ pgrid [label .topf.lrepo -textvariable ::repo] -row 0 -column 1
+ pgrid [label .topf.lluptodate -text "TL Manager up to date?" -anchor w] \
+ -row 1 -column 0
+ label .topf.luptodate -anchor w
+ pgrid .topf.luptodate -row 1 -column 1
+
+ pgrid [label .topf.llcmd -anchor w -text "Last command: "] \
+ -row 2 -column 0
+ pgrid [label .topf.lcmd -anchor w] -row 2 -column 1
+ pack .topf -side top -anchor w
+
+ # some buttons
+ spacing .
+ frame .butf
+ ttk::button .butf.all -text "Update all" -command update_all
+ ppack .butf.all -side left
+ .butf.all configure -state disabled
+ ttk::button .butf.self -text "Update self" -command update_self
+ .butf.self configure -state disabled
+ ppack .butf.self -side left
+ pack .butf -side top -anchor w
+
# command entry
spacing .
frame .ent
- pack [label .ent.l -text "Type command:"] -side left -padx 3
- pack [entry .ent.e -width 40] -side left -padx 3
- pack [ttk::button .ent.b -text Go -command run_entry] -side left -padx 3
+ ppack [label .ent.l -text "Type command:"] -side left
+ ppack [entry .ent.e -width 40] -side left -padx 3
+ ppack [ttk::button .ent.b -text Go -command run_entry] -side left
bind .ent.e <Return> run_entry
pack .ent -fill x -side top -expand 1
- #grid [label .ent.lprv -justify left -text "Last command entry: "] \
- # -row 1 -column 0
- #grid [label .ent.prv -justify left] -row 1 -column 1 -sticky w
+ spacing .
+ # controlling package list
+ ttk::frame .fp_ctrl
+ ppack [ttk::label .fp_ctrl.pkgl -text "Show packages:"] -side left
+ ttk::radiobutton .fp_ctrl.inst -text Installed -value inst \
+ -variable ::sel_opt -command show_packages_info
+ ttk::radiobutton .fp_ctrl.all -text All -value all \
+ -variable ::sel_opt -command show_packages_info
+ ttk::radiobutton .fp_ctrl.upd -text Updatable -value upd \
+ -variable ::sel_opt -command show_packages_info
+ ttk::radiobutton .fp_ctrl.coll -text Collections -value coll \
+ -variable ::sel_opt -command show_packages_info
+ ppack .fp_ctrl.inst -side left
+ ppack .fp_ctrl.all -side left
+ ppack .fp_ctrl.upd -side left
+ ppack .fp_ctrl.coll -side left
+ set ::sel_opt inst
+ pack .fp_ctrl -side top -fill x
+
# packages list (tlmgrgui uses an old HList widget)
- spacing .
frame .fpkg
ttk::treeview .pkglist -columns \
{mk name localrev remoterev shortdesc} \
@@ -525,7 +499,7 @@
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
+ pgrid .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 0 -weight 1
@@ -546,12 +520,16 @@
# bottom of main window
frame .endbuttons
- pack [ttk::button .q -text Quit -command exit] \
- -in .endbuttons -side right -padx 3 -pady 3
- pack [ttk::button .r -text "Restart self" -command restart_self] \
- -in .endbuttons -side right -padx 3 -pady 3
+ label .busy -textvariable ::busy -font TkHeadingFont -anchor w
+ ppack .busy -in .endbuttons -side left
+ ppack [ttk::button .q -text Quit -command exit] \
+ -in .endbuttons -side right
+ ppack [ttk::button .r -text "Restart self" -command restart_self] \
+ -in .endbuttons -side right
+ ppack [ttk::button .t -text "Restart tlmgr" -command restart_tlmgr] \
+ -in .endbuttons -side right
ttk::button .showlogs -text "Show logs" -command {wm state .lw normal}
- pack .showlogs -in .endbuttons -side right -padx 3
+ ppack .showlogs -in .endbuttons -side right
pack .endbuttons -side bottom -fill x -expand 1
# log displays: new toplevel
@@ -559,7 +537,7 @@
frame .lw.log
pack [ttk::scrollbar .lw.log.scroll -command ".lw.log.tx yview"] \
-side right -fill y
- pack [text .lw.log.tx -height 10 -bd 2 -relief groove -wrap word \
+ ppack [text .lw.log.tx -height 10 -bd 2 -relief groove -wrap word \
-yscrollcommand ".lw.log.scroll set"] \
-expand 1 -fill both
.lw.log.tx yview moveto 1
@@ -567,7 +545,7 @@
frame .lw.err
pack [ttk::scrollbar .lw.err.scroll -command ".lw.err.tx yview"] \
-side right -fill y
- pack [text .lw.err.tx -height 10 -bd 2 -relief groove -wrap word \
+ ppack [text .lw.err.tx -height 10 -bd 2 -relief groove -wrap word \
-yscrollcommand ".lw.err.scroll set"] \
-expand 1 -fill both
.lw.err.tx yview moveto 1
@@ -576,7 +554,7 @@
frame .lw.dbg
pack [ttk::scrollbar .lw.dbg.scroll -command ".lw.dbg.tx yview"] \
-side right -fill y
- pack [text .lw.dbg.tx -height 10 -bd 2 -relief groove -wrap word \
+ ppack [text .lw.dbg.tx -height 10 -bd 2 -relief groove -wrap word \
-yscrollcommand ".lw.dbg.scroll set"] \
-expand 1 -fill both
.lw.dbg.tx yview moveto 1
@@ -591,14 +569,30 @@
}
raise .lw.err .lw.logs
raise .lw.log .lw.logs
- pack .lw.logs -in .lw -side top -fill both -expand 1 -padx 3
+ pack .lw.logs -in .lw -side top -fill both -expand 1
+ frame .lw.bottom
ttk::button .lw.close -text close -command {wm withdraw .lw}
- pack .lw.close -side bottom -anchor e -padx 3 -pady 3
+ ppack .lw.close -in .lw.bottom -side right -anchor e
+ ppack [label .lw.status -anchor w] -in .lw.bottom -side left
+ pack .lw.bottom -side top -expand 1 -fill x
wm withdraw .lw
} ; # make_widgets
+proc enable_update_buttons {yesno} {
+ if {! $yesno || ! $::n_updates} {
+ .butf.all configure -state disabled
+ .butf.self configure -state disabled
+ } elseif $::need_update_self {
+ .butf.all configure -state disabled
+ .butf.self configure -state !disabled
+ } else {
+ .butf.all configure -state !disabled
+ .butf.self configure -state disabled
+ }
+}
+
proc enable_widgets {yesno} {
if $yesno {
set st normal
@@ -609,20 +603,190 @@
set ttk_st disabled
set ::busy "BUSY"
}
- # buttons
- .pkgl configure -state $ttk_st
+
+ enable_update_buttons $yesno
+
# command entry
.ent.b configure -state $st
.ent.e configure -state $st
- # package list
- .pkglist state $ttk_st
- # do not touch the log windows
+
# final buttons
.q configure -state $ttk_st
.r configure -state $ttk_st
+ .t configure -state $ttk_st
.showlogs configure -state $ttk_st
+
+ .lw.close configure -state $ttk_st
+ if $yesno {
+ .lw.status configure -text "Done"
+ } else {
+ .lw.status configure -text "Please wait..."
+ }
} ; # enable_widgets
+## single-package info ##
+
+proc popup_focused {itm} {
+ run_cmd_waiting "info $itm"
+ tk_messageBox -message [join $::out_log "\n"]
+}
+
+# filter procs; parameter is package name
+
+proc is_local {p} {
+ return [dict get $::pkgs $p localrev]
+}
+
+proc is_collection {p} {
+ set c [dict get $::pkgs $p "category"]
+ return [expr \"$c\" eq \"Collection\"]
+}
+
+proc is_updatable {p} {
+ #do_debug "Is $p updatable"
+ if [catch {dict get $::pkgs $p} pk] {
+ return 0
+ } else {
+ if [catch {dict get $::pkgs $p localrev} lr] {set lr 0}
+ if [catch {dict get $::pkgs $p remoterev} rr] {set rr 0}
+ # do_debug "Revisions $p are local $lr and remote $rr"
+ return [expr $lr > 0 && $rr > 0 && $rr > $lr]
+ }
+}
+
+# display packages: always display both local and remote revision columns.
+# ::pkgs should already be up to date
+
+# manual selection tags: unicode chars as tags are resolution-independent.
+# ATM we only display tags but do not use them otherwise.
+set mrk [format %c 0x25a3] ; # 'white square containing black small square'
+set nomrk [format %c 0x25a1] ; # 'white square'
+
+# sel_opt: which packages to show from package list;
+# after updates it will always be set to "inst", after installations "all"
+set sel_opt inst
+
+proc toggle_marked {itm cl} {
+ # if toggle_marked is triggered by a mouse click
+ # then it should do nothing unless it was a click in column #1
+ if {$cl ne "#1"} {
+ return
+ }
+ if [.pkglist tag has marked $itm] {
+ .pkglist tag remove marked $itm
+ .pkglist set $itm mk $::nomrk
+ } else {
+ .pkglist tag add marked $itm
+ .pkglist set $itm mk $::mrk
+ }
+} ; # toggle_marked
+
+proc display_packages_info {{filt ""}} {
+ do_debug "display_packages_info with remote $::have_remote and filt >$filt<"
+ .pkglist delete [.pkglist children {}]
+
+ foreach nm [lsort [dict keys $::pkgs]] {
+ if {$filt eq "" || [$filt $nm]} {
+ # collect data to be displayed for $nm in vl
+ set vl [list $::nomrk $nm]
+ foreach k {localrev remoterev shortdesc} {
+ set vv [dict get $::pkgs $nm $k]
+ if {$vv eq "0" || $vv == 0} {set vv ""}
+ lappend vl $vv
+ }
+ .pkglist insert {} end -id $nm -values $vl
+ } ; # else do not display
+ }
+ # also update displayed status info
+ if {$::have_remote && $::need_update_self} {
+ .topf.luptodate configure -text "Needs updating"
+ } elseif $::have_remote {
+ .topf.luptodate configure -text "Up to date"
+ } else {
+ .topf.luptodate configure -text "Unknown"
+ }
+ # ... and status of update buttons
+ enable_update_buttons 1
+} ; # display_packages_info
+
+# selection tags in package list
+# 1. selections themselves get lost too easily
+# 2. the -image option for ttk::treeview tags does not look right
+# Therefore a do-it-yourself implementation with column #1 reserved for
+# a marker, package name in column #2, and column #0 not displayed at all.
+# the marker could have been prefixed to the package name in column #0,
+# but I think a separate marker column is a cleaner solution.
+
+# display packages, invoking get_packages_info if necessary.
+# called at end of initialization and when a selection radio button
+# is clicked. Otherwise, get_packages_info_... and display_packages_info
+# are invoked separately.
+proc show_packages_info {} {
+ switch $::sel_opt {
+ "inst" {
+ if {! [llength [dict keys $::pkgs]]} {get_packages_info_local}
+ set filt "is_local"
+ }
+ "all" {
+ if {! $::have_remote} {get_packages_info_remote}
+ set filt ""
+ }
+ "upd" {
+ if {! $::have_remote} {get_packages_info_remote}
+ set filt "is_updatable"
+ }
+ "coll" {
+ if {! $::have_remote} {get_packages_info _remote}
+ set filt "is_collection"
+ }
+ }
+ display_packages_info $filt
+} ; # show_packages_info
+
+##### (re)initialization procs #####
+
+proc start_tlmgr {} {
+ # start the TeX Live Manager shell interface
+ # capture stdout into the pipe, stderr into a temp file
+ # below, vwait ::done_waiting forces tlshell
+ # to process initial tlmgr output before continuing
+ unset -nocomplain ::done_waiting
+ set ::tlshl [open "|tlmgr --machine-readable shell 2>>$::err_file" w+]
+ set ::err [open $::err_file r]
+ chan configure $::tlshl -buffering line -blocking 0
+ chan event $::tlshl readable read_line
+ vwait ::done_waiting
+ #get_repo
+ #if {$::argc && [lindex $::argv 0] eq "remote"} {
+ # show_packages_info 0 is_local
+ #} else {
+ # show_packages_info 1 is_local
+ #}
+}
+
+proc restart_tlmgr {} {
+ catch {chan close $::tlshl}
+ catch {chan close $::err}
+ start_tlmgr
+ get_packages_info_remote
+ display_packages_info
+}
+
+proc restart_self {{param ""}} {
+ do_debug "trying to restart"
+ if {$::progname eq ""} {
+ tk_messageBox -message "progname not found; not restarting"
+ return
+ }
+ 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 initialize {} {
# prepend TL to process searchpath (not needed on windows)
if {$::tcl_platform(platform) ne "windows"} {
@@ -680,9 +844,17 @@
# temp file for stderr
set ::err_file [maketemp ".err_tlshl"]
+ # logfile
+ set fname [file join $::tempsub \
+ [clock format [clock seconds] -format {%H:%M}]]
+ set ::flid [open $fname w]
+
make_widgets
start_tlmgr
+ get_repo
+ set ::sel_opt "inst"
+ show_packages_info
}; # initialize
initialize
More information about the tex-live-commits
mailing list