#!/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. ##### general housekeeping ##### # security: disable send catch {rename send {}} # menus: disable tearoff feature option add *Menu.tearOff 0 set plain_unix 0 if {$::tcl_platform(platform) eq "unix" && \ $::tcl_platform(os) ne "Darwin"} { set plain_unix 1 } set any_unix 0 if {$::tcl_platform(platform) eq "unix"} {set any_unix 1} set test {} 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_stacktrace {} { 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 } 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 tempsub "" ; # subdir for temp files, set during initialization proc search_nocase {needle haystack} { if {$needle eq ""} {return -1} if {$haystack eq ""} {return -1} return [string first [string tolower $needle] [string tolower $haystack]] } ##### tl global status variables ##### set last_cmd "" set progname [info script] regexp {^.*[\\/]([^\\/\.]*)(?:\....)?$} $progname dummy progname set procid [pid] # package repository (no suport for a one-off repository switch) set repo "" # while selecting another repo: set new_repo "" # mirrors: dict of dicts of lists of urls per country per continent set mirrors {} proc get_repo {} { run_cmd_waiting "option repository" # this returns the configured repository. # for now, do not support a temporary change. set re {repository\t(.*)$} foreach l $::out_log { if [regexp $re $l m ::repo] break } } ; # get_repo proc is_repo_local {r} { set db [file join $r "tlpkg/texlive.tlpdb"] return [file exists $db] } # the stderr and stdout of tlmgr are each read into a list of strings set err_log {} set out_log {} # dict of (local and global) package dicts set pkgs [dict create] set have_remote 0 ; # remote packages info not loaded set need_update_tlmgr 0 set n_updates 0 set tlshell_updatable 0 ## data to be displayed ## # sorted display data for packages set filtered [dict create] # selecting packages for display set stat_opt "inst" set dtl_opt "all" # searching packages for display set search_desc 0 ##### handling tlmgr via pipe and stderr tempfile ##### set prmpt "tlmgr>" set busy 0 # 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, 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 {} { 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 " puts stderr "Read failure; tlmgr command was $::last_cmd" catch {chan close $::tlshl} err_exit # note. the right way to terminate is terminating the GUI shell. # This closes stdin of tlmgr 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 ; # this may have to be redone later read_err if {$::pipe_cb ne ""} { do_debug "prompt found, $l" $::pipe_cb "finish" } # for vwait: set ::done_waiting 1 } else { lappend ::out_log $l if {$::pipe_cb ne ""} {$::pipe_cb "line" "$l"} } } } ; # read_line ##### 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" .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 ##### callbacks for file events of tlmgr pipe ::tlshl (names *_cb) ##### # callback for reading tlmgr pipe set pipe_cb "" # but maybe we just want a boolean whether or not to write # to the logs notebook. # consider writing log to file, always or on demand ## 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 BUT DO NOT TRIGGER ANOTHER EVENT LOOP # } else { # lappend ::err_log "Illegal call of whatever_cb" # err_exit # } #} 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 .lw.err.tx delete 1.0 end .lw.status configure -text "Running" .lw.close configure -state disabled wm state .lw normal wm deiconify .lw ;# also raises the window } 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 } .lw.status configure -text "" .lw.close configure -state !disabled } else { lappend ::err_log "Illegal call of log_widget_cb" err_exit } } ; # log_widget_cb ##### running tlmgr commands ##### ## general and various: 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 set ::last_cmd $cmd enable_widgets 0 set ::out_log {} set ::err_log {} 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 vwait ::done_waiting } 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 } ## package-related: what invokes what? # The 'globals' are: # ::have_remote is initialized to false. It is set to true by # get_packages_info_remote, and remains true. # The other globals ones are ::n_updates, ::need_update_tlmgr and # ::tlshell_updatable. These are initially set to 0 and re-calculated # by update_globals. # update_globals is invoked by get_packages_info_remote and # update_local_revnumbers. It enables and disables buttons as appropriate. # displayed global status info is updated by update_globals. # update button states are set at initialization and updated # by update_globals, both via the enable_update_buttons proc # get_packages_info_local is invoked only once, at initialization. After # installations and removals, the collected information is corrected by # update_local_revnumbers. # get_packages_info_remote will be invoked by collect_filtered if # ::have_remote is false. Afterwards, ::have_remote will be true, and # therefore get_packages_info_remote will not be called again. # get_packages_info_remote invokes update_globals. # update_local_revnumbers will be invoked after any updates. It also # invokes update_globals. # collect_filtered does not only filter, but also organize the # information to be displayed. If necessary, it invokes # get_packages_info_remote and always invokes display_packes_info. # It is invoked at initialization, when filtering options change and # at the end of install-, remove- and update procs. # display_packages_info is mostly invoked by collect_filtered, but # also when the search term or the search option changes. 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_tlmgr [expr {$b > 0} ? 1 : 0] return } } do_debug "check_tlmgr_uptodate: should not get here" } ; # check_tlmgr_uptodate proc is_updatable {nm} { set pk [dict get $::pkgs $nm] set lr [dict get $pk localrev] set rr [dict get $pk remoterev] return [expr $lr > 0 && $rr > 0 && $rr > $lr] } 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] # also update displayed status info if {$::have_remote && $::need_update_tlmgr} { .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: have columns for both local and remote revision numbers. # ::pkgs should already be up to date # I added a field 'marked' to ::pkgs. It is displayed in the first treeview # column. Treeview tags are not involved. proc mark_sym {mrk} { if $mrk { return "\u25A3" ; # 'white square containing black small square' } else { return "\u25A1" ; # 'white square' } } ; # mark_sym proc toggle_marked {itm cl} { # toggle_marked is triggered by a mouse click only in column #1. # 'marked' should get updated in ::pkgs, ::filtered and in .pkglist. if {$cl ne "#1"} { return } # $mrk: negation of current value of marked for $itm set mrk [expr [dict get $::pkgs $itm "marked"] ? 0 : 1] dict set ::pkgs $itm "marked" $mrk dict set ::filtered $itm [lreplace [dict get $::filtered $itm] 0 0 $mrk] .pkglist set $itm mk [mark_sym $mrk] } ; # toggle_marked proc mark_all {m} { foreach nm [dict keys $::pkgs] { dict set ::pkgs $nm "marked" $m } foreach nm [dict keys $::filtered] { dict set ::filtered $nm [lreplace [dict get $::filtered $nm] 0 0 $m] } foreach nm [.pkglist children {}] { .pkglist set $nm mk [mark_sym $m] } # alternatively: regenerate ::filtered and .pkglist from ::pkgs } # (re)create ::filtered dictionary; disregard search string proc collect_filtered {} { do_debug \ "collect_filtered for $::stat_opt and $::dtl_opt" if {$::stat_opt ne "inst" && ! $::have_remote} { get_packages_info_remote } foreach nm [dict keys $::filtered] { dict unset ::filtered $nm } foreach nm [lsort [dict keys $::pkgs]] { set pk [dict get $::pkgs $nm] set do_show 1 set mrk [mark_sym [dict get $pk marked]] set lr [dict get $pk localrev] set rr [dict get $pk remoterev] set ct [dict get $pk category] if {$::stat_opt eq "inst" && $lr == 0} { set do_show 0 } elseif {$::stat_opt eq "upd" && ($lr == 0 || $rr == 0 || $rr <= $lr)} { set do_show 0 } if {! $do_show} continue if {$::dtl_opt eq "schm" && $ct ne "Scheme"} { set do_show 0 } elseif {$::dtl_opt eq "coll" && \ $ct ne "Scheme" && $ct ne "Collection"} { set do_show 0 } if {! $do_show} continue # collect data to be displayed for $nm dict lappend ::filtered $nm $mrk dict lappend ::filtered $nm $nm set v [dict get $pk localrev] if {$v eq "0" || $v == 0} {set v ""} dict lappend ::filtered $nm $v set v [dict get $pk remoterev] if {$v eq "0" || $v == 0} {set v ""} dict lappend ::filtered $nm $v dict lappend ::filtered $nm [dict get $pk shortdesc] } display_packages_info } ; # collect_filtered # display packages obeying filter and search string. # even on a relatively slow system, regenerating the entire list # at every keystroke is acceptably responsive. # with future more advanced search options, this scheme may not suffice. proc display_packages_info {} { do_debug [get_stacktrace] set curr [.pksearch.e get] .pkglist delete [.pkglist children {}] dict for {nm pk} $::filtered { set do_show 0 if {$curr eq ""} { set do_show 1 } elseif {[search_nocase $curr $nm] >= 0} { set do_show 1 } elseif {$::search_desc && \ [search_nocase $curr [dict get $::pkgs $nm shortdesc]] >= 0} { set do_show 1 } if $do_show { .pkglist insert {} end -id $nm -values $pk } } } ; # display_packages_info proc toggle_search_desc {} { # when this proc is called, ::search_desc is not yet toggled # so we temporarily pre-toggle and post-untoggle it set ::search_desc [expr $::search_desc ? 0 : 1] display_packages_info set ::search_desc [expr $::search_desc ? 0 : 1] } # get fresh package list, invoked at program start # 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 proc get_packages_info_local {} { # start from scratch; see also update_local_revnumbers foreach nm [dict keys $::pkgs] { dict unset ::pkgs $nm } set ::have_remote 0 set ::need_update_tlmgr 0 set ::updatable 0 set ::tlshell_updatable 0 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 in short description: remove outer, unescape inner if {[string index $pdescr 0] eq "\""} { set pdescr [string range $pdescr 1 end-1] } set pdescr [string map {\\\" \"} $pdescr] dict set ::pkgs $nm \ [list "marked" 0 "localrev" $lrev "remoterev" 0 \ "category" $catg shortdesc $pdescr] } } } ; # get_packages_info_local # 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 } } set ::need_update_tlmgr 0 set ::updatable 0 set ::tlshell_updatable 0 if [catch {run_cmd_waiting \ "info --data name,localrev,remoterev,category,shortdesc"}] { do_debug [get_stacktrace] tk_messageBox -message \ "Repository $::repo unavailable. Please choose another one." return 0 } 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 [string map {\\\" \"} $pdescr] if [catch {dict get $::pkgs $nm} pk] { # package entry does not exist dict set ::pkgs $nm [dict create "marked" 0 "localrev" 0] } dict set ::pkgs $nm "remoterev" $rrev dict set ::pkgs $nm "category" $catg dict set ::pkgs $nm "shortdesc" $pdescr } } set ::have_remote 1 update_globals return 1 } ; # get_packages_info_remote ## update ::pkgs after installing packages without going online again. 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 update_tlmgr {} { if {! $::need_update_tlmgr} { tk_messageBox -message "Nothing to do!" return } run_cmd "update --self" log_widget_cb vwait ::done_waiting # tlmgr restarts itself automatically update_local_revnumbers collect_filtered } ; # update_tlmgr proc update_all {} { if $::need_update_tlmgr { tk_messageBox -message "Update self first!" return } elseif {! $::n_updates} { tk_messageBox -message "Nothing to do!" return } run_cmd "update --all" log_widget_cb vwait ::done_waiting update_local_revnumbers collect_filtered } ; # update_all ##### building GUI ##### # dummy widgets for vertical spacing within $w set idummy -1 proc spacing {w} { incr ::idummy pack [ttk::label $w.$::idummy -text " "] } proc pgrid {wdg args} { ; # grid command with padding grid $wdg {*}$args -padx 3 -pady 3 } proc ppack {wdg args} { ; # pack command with padding pack $wdg {*}$args -padx 3 -pady 3 } # mouse clicks: deal with MacOS platform differences if {[tk windowingsystem] eq "aqua"} { event add <> } else { event add <> } proc notyet {} { tk_messageBox -message "Not yet implemented" } ## default_bg , only used for menus under ::plain_unix if [catch {ttk::style lookup TFrame -background} ::default_bg] { set ::default_bg white } # The background color of a toplevel is 'set' by covering it # with a background ttk::frame. # Under MacOS we get the wrong answer with ttk::style lookup, # and the default is not right either. # place a toplevel centered wrt its parent. # if the geometry of the new toplevel cannot be determined, # its top left corner will be centered wrt its parent, which is not too bad. proc place_wrt {wnd {p ""}} { if {$p eq ""} { set p [winfo [winfo toplevel parent $wnd]] if {$p eq ""} return } update ; # try to ensure that geometry info is current set g [wm geometry $p] scan $g "%dx%d+%d+%d" pw ph px py set hcenter [expr $px + $pw / 2] set vcenter [expr $py + $ph / 2] set g [wm geometry $wnd] scan $g "%dx%d+%d+%d" ww wh wx wy set wx [expr $hcenter - $ww / 2] if {$wx < 0} { set wx 0} set wy [expr $vcenter - $wh / 2] if {$wy < 0} { set wy 0} wm geometry $wnd [format "+%d+%d" $wx $wy] wm attributes $wnd -topmost 1 wm attributes $p -topmost 0 wm deiconify $wnd raise $wnd $p } ; # place_wrt proc make_widgets {} { wm title . "$::progname $::procid" if $::any_unix {. configure -background $::default_bg} # width of '0', as a rough estimate of average character width set ::cw [font measure TkTextFont "0"] # menu menu .mn . configure -menu .mn if $::plain_unix { .mn configure -borderwidth 1 .mn configure -background $::default_bg # plain_unix: avoid a RenderBadPicture error on quitting. # 'send' changes the shutdown sequence, # which avoids triggering the bug. # 'tk appname ' restores send and avoids the bug bind . { catch {tk appname appname} } } .mn add cascade -label File -menu .mn.file -underline 0 menu .mn.file .mn.file add command -label "Load default repository" \ -command {get_packages_info_remote; collect_filtered} .mn.file add command -label "Load another repository" \ -command repositories .mn.file add command -command {destroy .} -label "Exit" -underline 1 .mn add cascade -label Options -menu .mn.opt -underline 0 menu .mn.opt .mn add cascade -label Actions -menu .mn.act -underline 0 menu .mn.act .mn add cascade -label Help -menu .mn.help -underline 0 menu .mn.help .mn.help add command -command {tk_messageBox -message "Helpless"} \ -label "About" # wallpaper frame pack [ttk::frame .bg] # various info ttk::frame .topf pgrid [ttk::label .topf.llrepo -text Repository -anchor w] \ -row 0 -column 0 -sticky w pgrid [ttk::label .topf.lrepo -textvariable ::repo] \ -row 0 -column 1 -sticky w ttk::label .topf.lluptodate -text "TL Manager up to date?" -anchor w pgrid .topf.lluptodate -row 1 -column 0 -sticky w ttk::label .topf.luptodate -text "Unknown" -anchor w pgrid .topf.luptodate -row 1 -column 1 -sticky w pgrid [ttk::label .topf.llcmd -anchor w -text "Last tlmgr command: "] \ -row 2 -column 0 -sticky w pgrid [ttk::label .topf.lcmd -anchor w -textvariable ::last_cmd] \ -row 2 -column 1 -sticky w pack .topf -in .bg -side top -anchor w # some buttons spacing .bg ttk::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 tlmgr" -command update_tlmgr .butf.self configure -state disabled ppack .butf.self -side left pack .butf -in .bg -side top -anchor w # command entry spacing .bg ttk::frame .ent ppack [ttk::label .ent.l -text "Type command:"] -side left ppack [ttk::entry .ent.e -width 40] -side left -padx 3 ppack [ttk::button .ent.b -text Go -command run_entry] -side left bind .ent.e run_entry pack .ent -in .bg -fill x -side top -expand 1 spacing .bg # package list ttk::label .lpack -text "Package list" -font TkHeadingFont -anchor w ppack .lpack -in .bg -side top -fill x # controlling package list ttk::frame .pkfilter # filter on status: inst, all, upd ttk::label .pkfilter.lstat -font TkHeadingFont -text "Status" ttk::radiobutton .pkfilter.inst -text Installed -value inst \ -variable ::stat_opt -command collect_filtered ttk::radiobutton .pkfilter.alls -text All -value all \ -variable ::stat_opt -command collect_filtered ttk::radiobutton .pkfilter.upd -text Updatable -value upd \ -variable ::stat_opt -command collect_filtered grid .pkfilter.lstat -column 0 -row 0 -sticky w -padx {3 50} pgrid .pkfilter.inst -column 0 -row 1 -sticky w pgrid .pkfilter.alls -column 0 -row 2 -sticky w pgrid .pkfilter.upd -column 0 -row 3 -sticky w # filter on detail level: all, coll, schm ttk::label .pkfilter.ldtl -font TkHeadingFont -text "Detail >> Global" ttk::radiobutton .pkfilter.alld -text All -value all \ -variable ::dtl_opt -command collect_filtered ttk::radiobutton .pkfilter.coll -text "Collections and schemes" -value coll \ -variable ::dtl_opt -command collect_filtered ttk::radiobutton .pkfilter.schm -text "Only schemes" -value schm \ -variable ::dtl_opt -command collect_filtered pgrid .pkfilter.ldtl -column 1 -row 0 -sticky w pgrid .pkfilter.alld -column 1 -row 1 -sticky w pgrid .pkfilter.coll -column 1 -row 2 -sticky w pgrid .pkfilter.schm -column 1 -row 3 -sticky w # marks grid [ttk::button .mrk_all -text "Mark all" -command {mark_all 1}] \ -in .pkfilter -column 2 -row 1 -sticky w -padx {50 3} grid [ttk::button .mrk_none -text "Mark none" -command {mark_all 0}] \ -in .pkfilter -column 2 -row 2 -sticky w -padx {50 3} pack .pkfilter -in .bg -side top -fill x # search interface ttk::frame .pksearch ppack [ttk::label .pksearch.l \ -text "Search package names"] \ -side left pack [ttk::entry .pksearch.e -width 30] -side left -padx {3 0} -pady 3 # cancel search: \u2A2F is 'vector or cross product' #pack [ttk::button .pksearch.can -text "X" -width 1 \ # -command {.pksearch.e delete 0 end}] -side left -padx {0 6} #pack [button .pksearch.can -text "\u2A2F" -padx 3 -pady 1 -borderwidth 1 \ # -command {.pksearch.e delete 0 end}] -side left -padx {0 6} #.pksearch.can configure -command \ # {.pksearch.e delete 0 end; display_packages_info} ppack [ttk::checkbutton .pksearch.d -variable ::search_desc \ -text "Also search short descriptions"] -side left pack .pksearch -in .bg -side top -fill x -expand 1 bind .pksearch.e display_packages_info bind .pksearch.d toggle_search_desc # packages list ttk::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} 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 pack .fpkg -in .bg -side top -expand 1 # "#1" refers to the first column (with mark symbols) bind .pkglist {toggle_marked [.pkglist focus] "#1"} bind .pkglist {toggle_marked [.pkglist focus] "#1"} # only toggle when column is "#1" bind .pkglist \ {toggle_marked \ [.pkglist identify item %x %y] \ [.pkglist identify column %x %y]} menu .pkg_popup ; # entries added on-the-fly bind .pkglist <> \ {do_package_popup %x %y %X %Y} if $::plain_unix { bind .pkg_popup {.pkg_popup unpost} } # bottom of main window ttk::frame .endbuttons ttk::label .busy -textvariable ::busy -font TkHeadingFont -anchor w ppack .busy -in .endbuttons -side left ppack [ttk::button .q -text Quit -command {destroy .}] \ -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 {close_tlmgr; start_tlmgr}] \ -in .endbuttons -side right ttk::button .showlogs -text "Show logs" \ -command {wm state .lw normal; place_wrt .lw .} ppack .showlogs -in .endbuttons -side right pack .endbuttons -in .bg -side bottom -fill x -expand 1 # log displays: new toplevel, again with themed background frame toplevel .lw wm title .lw Logs pack [ttk::frame .lw.bg] ttk::frame .lw.log pack [ttk::scrollbar .lw.log.scroll -command ".lw.log.tx yview"] \ -side right -fill y ppack [text .lw.log.tx -height 10 -wrap word \ -yscrollcommand ".lw.log.scroll set"] \ -expand 1 -fill both .lw.log.tx yview moveto 1 ttk::frame .lw.err pack [ttk::scrollbar .lw.err.scroll -command ".lw.err.tx yview"] \ -side right -fill y ppack [text .lw.err.tx -height 10 -wrap word \ -yscrollcommand ".lw.err.scroll set"] \ -expand 1 -fill both .lw.err.tx yview moveto 1 if $::ddebug { ttk::frame .lw.dbg pack [ttk::scrollbar .lw.dbg.scroll -command ".lw.dbg.tx yview"] \ -side right -fill y 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 } 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.bg -side top -fill both -expand 1 ttk::frame .lw.bottom ttk::button .lw.close -text close -command {wm withdraw .lw} ppack .lw.close -in .lw.bottom -side right -anchor e ppack [ttk::label .lw.status -anchor w] -in .lw.bottom -side left pack .lw.bottom -in .lw.bg -side top -expand 1 -fill x wm withdraw .lw } ; # make_widgets ## package popup ## proc run_package_cmd {cmd {chg 0}} { set mn [.pkglist focus] run_cmd "$cmd $mn" log_widget_cb vwait ::done_waiting if $chg { do_debug "Package_cmd $cmd; should call update_local_revnumbers" update_local_revnumbers collect_filtered } } ; # run_package_cmd proc do_package_popup {x y X Y} { # as focused item, the identity of the item will be globally available: .pkglist focus [.pkglist identify item $x $y] # recreate menu with only applicable items set lr [dict get $::pkgs [.pkglist focus] "localrev"] set rr [dict get $::pkgs [.pkglist focus] "remoterev"] .pkg_popup delete 0 end .pkg_popup add command -label "Info" -command \ {run_package_cmd "info"} if {$::have_remote && ! $::need_update_tlmgr && $rr > 0 && $lr == 0} { .pkg_popup add command -label "Install" -command \ {run_package_cmd "install" 1} } if {$::have_remote && ! $::need_update_tlmgr && $rr > $lr} { .pkg_popup add command -label "Update" -command \ {run_package_cmd "update" 1} } if {$lr > 0} { .pkg_popup add command -label "Remove" -command \ {run_package_cmd "remove" 1} } .pkg_popup post $X $Y focus .pkg_popup } ; # do_package_popup ### repositories proc repositories {} { set ::new_repo $::repo # look at dialog.tcl how to implement dialog-type behavior # toplevel with # - list of mirrors (parse tlpkg/installer/ctan-mirrors.pl) # - text entry box, or browser button # - ok and cancel buttons toplevel .tlr -class Dialog wm withdraw .tlr wm transient .tlr . wm title .tlr "Repositories" if $::plain_unix {wm attributes .tlr -type dialog} #if $::any_unix .tlr configure -background $::default_bg pack [ttk::frame .tlr.bg] pack [ttk::frame .tlr.info] -in .tlr.bg grid columnconfigure .tlr.info 1 -weight 1 set row -1 # current repository incr row pgrid [ttk::label .tlr.lcur -text "Current:"] \ -in .tlr.info -row $row -column 0 -sticky w pgrid [ttk::label .tlr.cur -textvariable ::repo] \ -in .tlr.info -row 0 -column 1 -sticky w # new repository incr row pgrid [ttk::label .tlr.lnew -text "New"] \ -in .tlr.info -row $row -column 0 -sticky w pgrid [ttk::entry .tlr.new -textvariable ::new_repo -width 40] \ -in .tlr.info -row $row -column 1 -columnspan 2 -sticky w ### three ways to specify a repository ### pack [ttk::frame .tlr.mirbuttons] -in .tlr.bg -fill x -expand 1 # default remote repository ttk::button .tlr.ctan -text "Any CTAN mirror" \ -command {set ::new_repo "http://mirror.ctan.org/systems/texlive/tlnet"} ppack .tlr.ctan -in .tlr.mirbuttons -side left -fill x -expand 1 # create a cascading mirror popup menu destroy .tlr.mir.m if {[dict size $::mirrors] == 0} read_mirrors if {[dict size $::mirrors] > 0} { ttk::menubutton .tlr.mir -text "Specific mirror..." -direction below \ -menu .tlr.mir.m ppack .tlr.mir -in .tlr.mirbuttons -side left -fill x -expand 1 menu .tlr.mir.m dict for {cont d_cont} $::mirrors { set c_ed [edit_name $cont] menu .tlr.mir.m.$c_ed .tlr.mir.m add cascade -label $cont -menu .tlr.mir.m.$c_ed dict for {cntr urls} $d_cont { set n_ed [edit_name $cntr] menu .tlr.mir.m.$c_ed.$n_ed .tlr.mir.m.$c_ed add cascade -label $cntr -menu .tlr.mir.m.$c_ed.$n_ed foreach u $urls { .tlr.mir.m.$c_ed.$n_ed add command -label $u \ -command "set ::new_repo $u" } } } } # local repository ttk::button .tlr.browse -text "Local directory..." \ -command find_local_repo ppack .tlr.browse -in .tlr.mirbuttons -side left -fill x -expand 1 spacing .tlr.bg # two ways to close the dialog pack [ttk::frame .tlr.closebuttons] -in .tlr.bg -fill x -expand 1 ttk::button .tlr.save -text "Save and Load" -command {close_repos "save"} ppack .tlr.save -in .tlr.closebuttons -side right ttk::button .tlr.abort -text "Abort" -command {close_repos "abort"} ppack .tlr.abort -in .tlr.closebuttons -side right place_wrt .tlr . grab set .tlr focus .tlr } ; # repositories proc close_repos {{how ""}} { raise . destroy .tlr if {$how eq "save"} { # the alternative set ::repo $::new_repo if {$::tcl_platform(platform) eq "windows"} { set ::repo [string map {\\ /} $::repo] } set ::new_repo "" run_cmd_waiting "option repository $::repo" close_tlmgr start_tlmgr # reload remote package information set ::have_remote 0 get_packages_info_remote collect_filtered } } proc find_local_repo {} { if [is_repo_local $::new_repo] { set inidir $::new_repo } elseif [is_repo_local $::repo] { set inidir $::repo } else { set inidir $::env(HOME) ; # HOME also ok for windows } set ::new_repo "" while 1 { set ::new_repo [tk_chooseDirectory -initialdir $inidir -mustexist 1 \ -parent .tlr -title "Local repository..."] if {$::new_repo ne "" && ! [is_repo_local $::new_repo]} { tk_messageBox -message "$::new_repo not a repository" set inidir $::new_repo set ::new_repo "" continue } else { break } } } ; # find_local_repo ### mirrors set mirrors [dict create] proc read_mirrors {} { if [catch {open [file join [exec kpsewhich -var-value SELFAUTOPARENT] \ "tlpkg/installer/ctan-mirrors.pl"] r} fm] {return 0} set re_geo {^\s*'([^']+)' => \{\s*$} set re_url {^\s*'(.*)' => ([0-9]+)} set re_clo {^\s*\},?\s*$} set starting 1 set lnum 0 ; # line number for error messages set ok 1 ; # no errors encountered yet set countries {} ; # aggregate list of countries set urls {} ; # aggregate list of urls set continent "" set country "" set u "" set in_cont 0 set in_coun 0 while {! [catch {chan gets $fm} line] && ! [chan eof $fm]} { incr lnum if $starting { if {[string first "\$mirrors =" $line] == 0} { set starting 0 continue } else { set ok 0 set msg "Unexpected line '$line' at start" break } } # starting is now dealt with. if [regexp $re_geo $line dummy c] { if {! $in_cont} { set in_cont 1 set continent $c set cont_dict [dict create] if {$continent in [dict keys $::mirrors]} { set ok 0 set msg "Duplicate continent $c at line $lnum" break } } elseif {! $in_coun} { set in_coun 1 set country $c if {$country in $countries} { set ok 0 set msg "Duplicate country $c at line $lnum" break } lappend countries $country dict set cont_dict $country {} } else { set ok 0 set msg "Unexpected continent- or country line $line at line $lnum" break } } elseif [regexp $re_url $line dummy u n] { if {! $in_coun} { set ok 0 set msg "Unexpected url line $line at line $lnum" break } elseif {$n ne "1"} { continue } append u "systems/texlive/tlnet" if {$u in $urls} { set ok 0 set msg "Duplicate url $u at line $lnum" break } dict lappend cont_dict $country $u lappend urls $u set u "" } elseif [regexp $re_clo $line] { if $in_coun { set in_coun 0 set country "" } elseif $in_cont { set in_cont 0 dict set ::mirrors $continent $cont_dict set continent "" } else { break ; # should close mirror list } } ; # ignore other lines } close $fm if {! $ok} {do_debug $msg} # relocate Australia and New Zealand if they are # classified under North America dict set ::mirrors "Other" [dict create] set dict_nam [dict get $::mirrors "North America"] foreach c {"Australia" "New Zealand"} { if [dict exists $dict_nam $c] { dict set ::mirrors "Other" $c [dict get $dict_nam $c] dict unset ::mirrors "North America" $c } } if {[dict size [dict get $::mirrors "Other"]] == 0} { dict unset ::mirrors "Other" } } ; # read_mirrors proc edit_name {n} { set n [string tolower $n] set n [string map {" " "_"} $n] return $n } ; # edit_name proc enable_update_buttons {yesno} { if {! $yesno || ! $::n_updates} { .butf.all configure -state disabled .butf.self configure -state disabled } elseif $::need_update_tlmgr { .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} { enable_update_buttons $yesno if $yesno { set st normal set ttk_st !disabled set ::busy "IDLE" } else { set st disabled set ttk_st disabled set ::busy "BUSY" } # command entry .ent.b configure -state $st .ent.e configure -state $st # 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 ##### (re)initialization procs ##### proc start_tlmgr {{args ""}} { # 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 do_debug "opening tlmgr" if [catch \ {open "|tlmgr $args --machine-readable shell 2>>$::err_file" w+} \ ::tlshl] { tk_messageBox -message [get_stacktrace] exit } #set ::tlshl [open "|tlmgr $args --machine-readable shell 2>>$::err_file" w+] do_debug "done opening tlmgr" set ::err [open $::err_file r] chan configure $::tlshl -buffering line -blocking 0 chan event $::tlshl readable read_line vwait ::done_waiting } proc close_tlmgr {} { catch {chan close $::tlshl} catch {chan close $::err} } proc change_repo {} { run_cmd_waiting "option repository $::repo" get_packages_info_remote } proc restart_self {} { do_debug "trying to restart" if {$::progname eq ""} { tk_messageBox -message "progname not found; not restarting" return } close_tlmgr exec $::progname & # on windows, it may take several seconds before # the old tlshell disappears. # oh well, windows is still windows.... destroy . } ; # restart_self 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 {$tmp in [array names ::env]} { lappend attemptdirs $::env($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"] # logfile if $::ddebug { set fname [file join $::tempsub \ [clock format [clock seconds] -format {%H:%M}]] set ::flid [open $fname w] } # add json subdirectory to auto_path, but at low priority # since the tcl/tk installation may already have a better implementation. # Use kpsewhich to find out own directory and bypass symlinks. #set tlsdir [file dirname [exec kpsewhich -format texmfscripts tlshell.tcl]] #lappend ::auto_path [file join $tlsdir "json"] make_widgets start_tlmgr get_repo get_packages_info_local collect_filtered ; # invokes display_packages_info enable_update_buttons 1 }; # initialize initialize