#!/usr/bin/env wish # Copyright 2017 Siep Kroonenberg # This file is licensed under the GNU General Public License version 2 # or any later version. package require Tk # 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. # kpsewhich will disentangle symlinks. # security: disable send catch {rename send {}} set ddebug 0 proc do_debug {s} { if {$::ddebug} { puts stderr $s # catch in case the widget concerned has not yet been created catch {.lw.dbg.tx configure -state normal; .lw.dbg.tx insert end "$s\n"} } } proc get_stack {} { set level [info level] set s "" for {set i 1} {$i < $level} {incr i} { append s [format "Level %u: %s\n" $i [info level $i]] } 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. set mrk [format %c 0x25a3] ; # 'white square containing black small square' set nomrk [format %c 0x25a1] ; # 'white square' set progname [info script] regexp {^.*[\\/]([^\\/\.]*)(?:\....)?$} $progname dummy progname set procid [pid] set tempsub "" ; # subdirectory for temporary files # 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 # filtering the package list, parameter should be package NAME set filt "" 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 proc err_exit {} { do_debug "error exit" read_err tk_messageBox -message [join $::err_log "\n"] -type ok -icon error exit } proc read_err {} { #do_debug "read_err" set len 0 while 1 { set len [chan gets $::err l] if {$len >= 0} { lappend ::err_log $l } else { break } } } # about [chan] gets: # if a second parameter 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. proc read_line {} { incr ::lnum set l "" ; # will contain the line to be read if {([catch {chan gets $::tlshl l} len] || [chan eof $::tlshl])} { do_debug "read_line: failing to read" catch {chan close $::tlshl} err_exit # note. the right way to terminate is terminating the shell } elseif {$len >= 0} { # do_debug "read: $l" if {[string first $::prmpt $l] == 0} { # prompt line: done with command enable_widgets 1 read_err if {$::pipe_cb ne ""} { do_debug "$::lnum: prompt found, $l" $::pipe_cb "finish" } } else { lappend ::out_log $l if {$::pipe_cb ne ""} {$::pipe_cb "line" "$l"} } } } ; # read_line # copy error strings to error 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" .lw.err.tx configure -state normal .lw.err.tx delete 1.0 end if {[llength $::err_log] > 0} { foreach l $::err_log {.lw.err.tx insert end "$l\n"} .lw.err.tx yview moveto 1 .lw.logs select .lw.err } if {$::tcl_platform(os) ne "Darwin"} { # os x: text widget disabled => no selection possible .lw.err.tx configure -state disabled } } ; # show_err_log # package info popup for the package having focus proc popup_focused {itm} { run_cmd "info $itm" package_popup_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 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"} { # # 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 # } #} 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 .lw.log.tx insert end "$l\n" } elseif {$mode eq "init"} { .lw.log.tx configure -state normal .lw.log.tx delete 1.0 end } elseif {$mode eq "finish"} { .lw.log.tx yview moveto 1 .lw.logs select .lw.log # error log on top if it contains anything show_err_log if {$::tcl_platform(os) ne "Darwin"} { .lw.log.tx configure -state disabled } .ent.e configure -state normal } else { lappend ::err_log "Illegal call of log_widget_cb" err_exit } } ; # 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 proc package_popup_cb {mode {l ""}} { if {$mode eq "finish"} { tk_messageBox -message [join $::out_log "\n"] } } # procs involving running tlmgr commands ######################### proc run_cmd {cmd {cb ""}} { set ::pipe_cb $cb do_debug "run_cmd \"$cmd\"" enable_widgets 0 set ::out_log {} set ::err_log {} set ::lnum 0 if {$::pipe_cb ne ""} {$::pipe_cb "init"} chan puts $::tlshl $cmd chan flush $::tlshl } 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 run_cmd $cmd log_widget_cb } proc package_popup {itm} { # tk_messageBox -message $itm run_cmd "info $itm" package_popup_cb } # 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 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 } } ; # show_all_packages 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 } } ; # show_local_packages proc show_collections {} { set ::filt filt_collections if {! $::have_remote} { set ::do_remote 1 get_and_display_packages } else { display_packages } } ; # show_collections 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 } } ; # show_upgradable # (re)initialization procs ############################ 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 restart_self {} { 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 } # dummy widgets for vertical spacing set idummy -1 proc spacing {w} { incr ::idummy 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 make_widgets {} { wm title . "$::progname $::procid" # width of '0', as a rough estimate of 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 # 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 bind .ent.e 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 # packages list (tlmgrgui uses an old HList widget) spacing . frame .fpkg ttk::treeview .pkglist -columns \ {mk name localrev remoterev shortdesc} \ -show headings -height 8 -selectmode extended \ -xscrollcommand {.pkhsb set} -yscrollcommand {.pkvsb set} foreach \ col {mk name localrev remoterev shortdesc} \ nm {"" Name "Local Rev." "Remote Rev." Description} { .pkglist heading $col -text $nm -anchor w } .pkglist column mk -width [expr $cw * 3] .pkglist column name -width [expr $cw * 25] .pkglist column localrev -width [expr $cw * 12] .pkglist column remoterev -width [expr $cw * 12] .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 0 -weight 1 pack .fpkg -side top -expand 1 bind .pkglist {toggle_marked [.pkglist focus] "#1"} bind .pkglist {toggle_marked [.pkglist focus] "#1"} bind .pkglist {toggle_marked \ [.pkglist identify item %x %y] [.pkglist identify column %x %y]} bind .pkglist \ {popup_focused [.pkglist identify item %x %y]} bind .pkglist \ {popup_focused [.pkglist identify item %x %y]} bind .pkglist \ {popup_focused [.pkglist identify item %x %y]} bind .pkglist \ {popup_focused [.pkglist identify item %x %y]} # 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 ttk::button .showlogs -text "Show logs" -command {wm state .lw normal} pack .showlogs -in .endbuttons -side right -padx 3 pack .endbuttons -side bottom -fill x -expand 1 # log displays: new toplevel toplevel .lw 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 \ -yscrollcommand ".lw.log.scroll set"] \ -expand 1 -fill both .lw.log.tx yview moveto 1 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 \ -yscrollcommand ".lw.err.scroll set"] \ -expand 1 -fill both .lw.err.tx yview moveto 1 if $::ddebug { 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 \ -yscrollcommand ".lw.dbg.scroll set"] \ -expand 1 -fill both .lw.dbg.tx yview moveto 1 } ttk::notebook .lw.logs .lw.logs add .lw.log -text "Output" .lw.logs add .lw.err -text "Errors" if $::ddebug { .lw.logs add .lw.dbg -text "Debug" raise .lw.dbg .lw.logs } raise .lw.err .lw.logs raise .lw.log .lw.logs pack .lw.logs -in .lw -side top -fill both -expand 1 -padx 3 ttk::button .lw.close -text close -command {wm withdraw .lw} pack .lw.close -side bottom -anchor e -padx 3 -pady 3 wm withdraw .lw } ; # 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 .pkgl configure -state $ttk_st # 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 .showlogs configure -state $ttk_st } ; # enable_widgets proc initialize {} { # prepend TL to process searchpath (not needed on windows) if {$::tcl_platform(platform) ne "windows"} { set texbin [file dirname [info script]] set savedir [pwd] cd $texbin set texbin [pwd] cd $savedir # prepend texbin to PATH, unless it is already the _first_ # path component if {$::tcl_platform(platform) eq "unix"} { set pathsep ":" } else { set pathsep ";" } set dirs [split $::env(PATH) $pathsep] if {[lindex $dirs 0] ne $texbin} { set ::env(PATH) "$texbin$pathsep$::env(PATH)" } } # directory for temp files set attemptdirs {} foreach tmp {TMPDIR TEMP TMP} { if {[lsearch [array names ::env] $tmp] >= 0} { lappend attemptdirs $::env($tmp) } } if {$::tcl_platform(os) eq "Darwin"} { lappend attemptdirs "/private/tmp" } if {$::tcl_platform(platform) eq "unix"} { lappend attemptdirs "/tmp" } lappend attemptdirs [pwd] set ::tempsub "" foreach tmp $attemptdirs { if {$::tcl_platform(platform) eq "windows"} { regsub -all {\\} $tmp {/} tmp } if {[file isdirectory $tmp]} { # no real point in randomizing directory name itself if {$::tcl_platform(platform) eq "unix"} { set ::tempsub [file join $tmp $::env(USER)] } else { set ::tempsub [file join $tmp $::env(USERNAME)] } append ::tempsub "-tlshell" if {! [catch {file mkdir $::tempsub}]} {break} ;# success } } if {$::tempsub eq "" || [file isdirectory $::tempsub] == 0} { error "Cannot create directory for temporary files" } # temp file for stderr set ::err_file [maketemp ".err_tlshl"] make_widgets start_tlmgr }; # initialize initialize