diff options
| -rwxr-xr-x | Master/texmf-dist/scripts/tlshell/tlshell.tcl | 79 |
1 files changed, 65 insertions, 14 deletions
diff --git a/Master/texmf-dist/scripts/tlshell/tlshell.tcl b/Master/texmf-dist/scripts/tlshell/tlshell.tcl index 1cdd4590a2e..3dc2064ac47 100755 --- a/Master/texmf-dist/scripts/tlshell/tlshell.tcl +++ b/Master/texmf-dist/scripts/tlshell/tlshell.tcl @@ -23,14 +23,26 @@ set err_log {} set out_log {} # dicts of package dicts +set pkgs {} +if 0 { set pkgs_local {} set pkgs_remote {} set pkgs pkgs_local +} set prmpt "tlmgr>" set busy 0 set ddebug 1 +if $::ddebug { + frame .dbg + pack [ttk::scrollbar .dbg.scroll -command ".dbg.tx yview"] \ + -side right -fill y + pack [text .dbg.tx -height 10 -bd 2 -relief groove -wrap word \ + -yscrollcommand ".dbg.scroll set"] \ + -expand 1 -fill both + .dbg.tx yview moveto 1 +} proc do_debug {s} { if {$::ddebug} { puts stderr $s @@ -128,6 +140,7 @@ proc selection_popup {sl} { # combined display of local and remote package database information # in treeview widget +if 0 { proc display_packages {} { set pknames {} .pkglist delete [.pkglist children {}] @@ -172,6 +185,7 @@ proc display_packages {} { } update ; # uncomment if necessary } ; # display_packages +} # callbacks for file events of tlmgr pipe ::tlshl (names *_cb) ### @@ -215,6 +229,41 @@ proc log_widget_cb {mode {l ""}} { } } ; # log_widget_cb +proc packages_cb {mode {l ""}} { + if {$mode eq "line"} { + # .pkglist configure -state normal + # set re {^([ i]) ([^: ]+): (.*)$} + #set re {^[^,]+,([0-9]+),([0-9]+),([^,]*),(\\\".*\\\")?$} + set re {^([^,]+),([0-9]+),([0-9]+),([^,]*),(.*)$} + if {[regexp $re $l m pname lrev rrev catg pdescr]} { + # do_debug "Match: $pname -- $lrev -- $rrev -- $catg -- $pdescr" + if {[string index $pdescr 0] eq "\""} { + set pdescr [string range $pdescr 1 end-1] + } + set pdescr [regsub -all "\\\"" $pdescr "\""] + dict set ::pkgs $pname \ + [list "lrev" $lrev "rrev" $rrev "category" $catg shortdesc $pdescr] + if {$lrev == 0} { set lrev {}} + .pkglist insert {} end -id $pname -values \ + [list $pname $lrev $rrev $pdescr] + } else { + do_debug "No match: $l" + } + return + } elseif {$mode eq "init"} { + # is this useful? or will the garbage collector take care of it? + foreach nm [dict keys $::pkgs] {dict set ::pkgs $nm {}} + set ::pkgs {} + return + } elseif {$mode eq "finish"} { + return + } else { + lappend ::err_log "Illegal call of packages_cb" + err_exit + } +} ; # packages_cb + +if 0 { proc dump_db_cb {mode {l ""}} { upvar #0 $::pkgs pk if {$mode eq "line"} { @@ -262,7 +311,7 @@ proc dump_db_cb {mode {l ""}} { err_exit } } ; # dump_db_cb - +} proc package_popup_cb {mode {l ""}} { if {$mode eq "finish"} { tk_messageBox -message [join $::out_log "\n"] @@ -302,12 +351,20 @@ proc package_popup {it} { } # $db should be either local or remote +if 0 { proc dump_db {db} { do_debug "reading $db" set ::pkgs pkgs_$db set ::pipe_cb dump_db_cb run_cmd "dump-tlpdb --$db" } +} + +# complete package list +proc list_packages {} { + set ::pipe_cb packages_cb + run_cmd "info --data name,localrev,remoterev,category,shortdesc" +} # (re)initialization procs ############################ @@ -346,12 +403,17 @@ proc make_widgets {} { frame .buttons grid [label .more -justify left -text "Buttons (more to come)"] \ -in .buttons -column 0 -columnspan 3 -row 0 -sticky w + grid [ttk::button .pkgl -text "Show all packages" \ + -command list_packages] \ + -in .buttons -column 0 -row 1 -sticky w + if 0 { 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 @@ -415,23 +477,13 @@ proc make_widgets {} { -expand 1 -fill both .err.tx yview moveto 1 - if $::ddebug { - frame .dbg - pack [ttk::scrollbar .dbg.scroll -command ".dbg.tx yview"] \ - -side right -fill y - pack [text .dbg.tx -height 10 -bd 2 -relief groove -wrap word \ - -yscrollcommand ".dbg.scroll set"] \ - -expand 1 -fill both - .dbg.tx yview moveto 1 - } + # .dbg notbook tab created early on ttk::notebook .logs .logs add .log -text "Output" .logs add .err -text "Errors" if $::ddebug { .logs add .dbg -text "Debug" - } - if $::ddebug { raise .dbg .logs } raise .err .logs @@ -458,8 +510,7 @@ proc enable_widgets {yesno} { set ::busy "BUSY" } # buttons - .locals configure -state $ttk_st - .remotes configure -state $ttk_st + .pkgl configure -state $ttk_st # command entry .ent.b configure -state $st .ent.e configure -state $st |