#!/usr/bin/env wish 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 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 {} # 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 .dbg.tx configure -state normal .dbg.tx insert end "$s\n" } } 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 { return } } } # 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 {} { 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 } elseif {$len >= 0} { # do_debug "read: $l" if {[string first $::prmpt $l] == 0} { # prompt line: done with command read_err enable_widgets 1 $::pipe_cb "finish" } else { lappend ::out_log $l $::pipe_cb "line" "$l" } } } proc show_err {} { do_debug "show_err" .err.tx configure -state normal .err.tx delete 1.0 end if {[llength $::err_log] > 0} { foreach l $::err_log {.err.tx insert end "$l\n"} .err.tx yview moveto 1 .logs select .err } if {$::tcl_platform(os) ne "Darwin"} { # os x: text widget disabled => no selection possible .err.tx configure -state disabled } } proc focus_popup {it} { set ::pipe_cb package_popup_cb run_cmd "info $it" } set mrk [format %c 9635] ; # black square, in decimal set nomrk [format %c 9633] ; # white square, in decimal proc toggle_marked {it cl} { if {$cl ne "#1"} { return } if [.pkglist tag has marked $it] { .pkglist tag remove marked $it .pkglist set $it mk $::nomrk } else { .pkglist tag add marked $it .pkglist set $it mk $::mrk } } # 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 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 log_widget_cb {mode {l ""}} { if {$mode eq "line"} { .log.tx configure -state normal .log.tx insert end "$l\n" } elseif {$mode eq "init"} { .log.tx configure -state normal .log.tx delete 1.0 end } elseif {$mode eq "finish"} { .log.tx yview moveto 1 .logs select .log # error log on top if it contains anything show_err if {$::tcl_platform(os) ne "Darwin"} { .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 {$mode eq "line"} { 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 $::nomrk $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 #proc dump_db_cb {mode {l ""}} { # upvar #0 $::pkgs pk # if {$mode eq "line"} { # 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 { # 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"} { # set pk {} # set ::cur_pkg "" # return # } elseif {$mode eq "finish"} { # display_packages # return # } else { # lappend ::err_log "Illegal call of dump_db_cb" # err_exit # } #} ; # dump_db_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} { 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 "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 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 ############################ proc start_tlmgr {} { # start the TeX Live Manager shell interface # capture stdout into the pipe, stderr into a temp file 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 set ::pipe_cb empty_cb } 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 } proc make_widgets {} { wm title . "$::progname $::procid" # width of '0', as a rough estimate of character width set cw [font measure TkTextFont "0"] 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 frame .ent grid [label .ent.l -text "Type command:" -justify left] -row 0 -column 0 \ -sticky w grid [ttk::button .ent.b -text Run -command run_entry] \ -row 0 -column 2 -sticky w grid [entry .ent.e -width 20] -row 0 -column 1 -sticky ew bind .ent.e run_entry 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 grid [label .ent.busy -justify right -textvariable ::busy] \ -row 1 -column 2 grid columnconfigure .ent 1 -weight 1 pack .ent -fill x -side top -expand 1 # packages list (tlmgrgui uses an old HList widget) 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] mk} bind .pkglist {toggle_marked [.pkglist focus] mk} bind .pkglist {toggle_marked \ [.pkglist identify item %x %y] [.pkglist identify column %x %y]} bind .pkglist \ {focus_popup [.pkglist identify item %x %y]} bind .pkglist \ {focus_popup [.pkglist identify item %x %y]} bind .pkglist \ {focus_popup [.pkglist identify item %x %y]} bind .pkglist \ {focus_popup [.pkglist identify item %x %y]} # log displays frame .log pack [ttk::scrollbar .log.scroll -command ".log.tx yview"] \ -side right -fill y pack [text .log.tx -height 10 -bd 2 -relief groove -wrap word \ -yscrollcommand ".log.scroll set"] \ -expand 1 -fill both .log.tx yview moveto 1 frame .err pack [ttk::scrollbar .err.scroll -command ".err.tx yview"] \ -side right -fill y pack [text .err.tx -height 10 -bd 2 -relief groove -wrap word \ -yscrollcommand ".err.scroll set"] \ -expand 1 -fill both .err.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" raise .dbg .logs } raise .err .logs raise .log .logs pack .logs -side top -fill x -expand 1 -padx 3 -pady 6 # finally... frame .endbuttons pack [ttk::button .q -text Quit -command exit] \ -in .endbuttons -side right 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 .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 } ; # 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