summaryrefslogtreecommitdiff
path: root/Master/texmf-dist/scripts/tlshell/tlshell.tcl
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2017-08-22 14:36:53 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2017-08-22 14:36:53 +0000
commit1870a172c11fb0467f2cdd4892c519befe3674db (patch)
treef2b174a85c58e16e4bb3bec9a136315ba8c04377 /Master/texmf-dist/scripts/tlshell/tlshell.tcl
parent81fbb26155957f6b9a11f9621783ed2fe1b5e0b4 (diff)
Complete local and remote package listings
git-svn-id: svn://tug.org/texlive/trunk@45094 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/texmf-dist/scripts/tlshell/tlshell.tcl')
-rwxr-xr-xMaster/texmf-dist/scripts/tlshell/tlshell.tcl275
1 files changed, 200 insertions, 75 deletions
diff --git a/Master/texmf-dist/scripts/tlshell/tlshell.tcl b/Master/texmf-dist/scripts/tlshell/tlshell.tcl
index 86906dcf2b5..b20cf46a0c2 100755
--- a/Master/texmf-dist/scripts/tlshell/tlshell.tcl
+++ b/Master/texmf-dist/scripts/tlshell/tlshell.tcl
@@ -5,17 +5,15 @@ package require Tk
# - 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.
-
-# short wait in case of restart. Would this be useful?
-# after 100
+# kpsewhich will disentangle symlinks.
-# for security:
+# security: disable send
catch {rename send {}}
set progname [info script]
@@ -28,13 +26,18 @@ set tempsub "" ; # subdirectory for temporary files
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 @@ proc maketemp {ext} {
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 @@ proc read_line {} {
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 @@ proc show_err {} {
}
}
-# 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 @@ proc log_widget_cb {mode {l ""}} {
}
} ; # 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 @@ proc package_popup_cb {mode {l ""}} {
}
}
-# 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 @@ proc start_tlmgr {} {
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 @@ proc restart_self {} {
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 @@ proc make_widgets {} {
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 @@ proc make_widgets {} {
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 @@ proc make_widgets {} {
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"} {