#!/usr/bin/env wish # Copyright 2017, 2018 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. # dis/enable restore dialog set do_restore 0 # dis/enable debug output (only for private development purposes) set ddebug 0 ##### general housekeeping ############################################ # security: disable send catch {rename send {}} # menus: disable tearoff feature option add *Menu.tearOff 0 # no bold text for messages option add *Dialog.msg.font TkDefaultFont userDefault ## italicized items; not used #font create it_font {*}[font configure TkDefaultFont] #font configure it_font -slant italic set plain_unix 0 if {$::tcl_platform(platform) eq "unix" && \ $::tcl_platform(os) ne "Darwin"} { set plain_unix 1 } proc search_nocase {needle haystack} { if {$needle eq ""} {return -1} if {$haystack eq ""} {return -1} return [string first [string tolower $needle] [string tolower $haystack]] } # the stderr and stdout of tlmgr are each read into lists of strings set err_log {} set out_log {} #### debug output, ATM only for private development purposes #### if $ddebug {set dbg_log {}} proc do_debug {s} { if $::ddebug { puts stderr $s # On windows, stderr output goes nowhere. # Therefore also debug output for the log toplevel. lappend ::dbg_log $s # Track debug output in the log toplevel if it is running: if [winfo exists .tllg.dbg.tx] { .tllg.dbg.tx configure -state normal .tllg.dbg.tx insert end "$s\n" if {$::tcl_platform(os) ne "Darwin"} { .tllg.dbg.tx configure -state disabled } } } } ; # do_debug 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 } ; # get_stacktrace 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 ### GUI utilities ##################################################### # 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 <> } ## default_bg color, only used for menus under ::plain_unix if [catch {ttk::style lookup TFrame -background} ::default_bg] { set ::default_bg white } # unicode symbols as fake checkboxes in ttk::treeview widgets proc mark_sym {mrk} { if $mrk { return "\u25A3" ; # 'white square containing black small square' } else { return "\u25A1" ; # 'white square' } } ; # mark_sym # place a toplevel, or at least its upperleft corner, centered wrt its parent proc place_dlg {wnd {p ""}} { if {$p eq ""} { set p [winfo toplevel [winfo parent $wnd]] if {$p eq ""} return } 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] set wh [winfo reqheight $wnd] set ww [winfo reqwidth $wnd] 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 state $wnd normal raise $wnd $p tkwait visibility $wnd if {$::tcl_platform(platform) ne "windows"} { # dont understand why these give trouble in windows focus $wnd grab set $wnd } } ; # place_dlg proc long_message {str type {p "."}} { # alternate messagebox implemented as custom dialog # not all message types are supported if {$type ne "ok" && $type ne "okcancel" && $type ne "yesnocancel"} { err_exit "Illegal type $type for long_message" } set ::lms_parent $p unset -nocomplain ::lms_var do_debug "type $type" catch {destroy .tlmg} toplevel .tlmg -class Dialog wm withdraw .tlmg wm transient .tlmg . if $::plain_unix {wm attributes .tlmg -type dialog} # wallpaper frame; see make_widgets pack [ttk::frame .tlmg.bg] -fill both -expand 1 ppack [ttk::frame .tlmg.tx] -in .tlmg.bg -side top -fill both -expand 1 pack [ttk::scrollbar .tlmg.tx.scroll -command ".tlmg.tx.txt yview"] \ -side right -fill y ppack [text .tlmg.tx.txt -height 20 -width 60 -bd 2 -relief groove \ -wrap word -yscrollcommand ".tlmg.tx.scroll set"] -expand 1 -fill both .tlmg.tx.txt insert end $str .tlmg.tx.txt configure -state disabled # buttons pack [ttk::frame .tlmg.bts] -in .tlmg.bg -side bottom -fill x if {$type eq "ok" || $type eq "okcancel"} { ttk::button .tlmg.ok -text "ok" -command \ {raise $::lms_parent; destroy .tlmg; set ::lms_var "ok"} ppack .tlmg.ok -in .tlmg.bts -side right } if {$type eq "yesnocancel"} { ttk::button .tlmg.yes -text "yes" -command \ {raise $::lms_parent; destroy .tlmg; set::lms_var "yes"} ppack .tlmg.yes -in .tlmg.bts -side right ttk::button .tlmg.no -text "no" -command \ {raise $::lms_parent; destroy .tlmg; set ::lms_var "no"} ppack .tlmg.no -in .tlmg.bts -side right } if {$type eq "yesnocancel" || $type eq "okcancel"} { ttk::button .tlmg.cancel -text "cancel" -command \ {raise $::lms_parent; destroy .tlmg; set ::lms_var "cancel"} ppack .tlmg.cancel -in .tlmg.bts -side right } place_dlg .tlmg $::lms_parent tkwait variable ::lms_var return $::lms_var } ; # long_message proc any_message {str type {p "."}} { if {[string length $str] < 400} { if {$type ne "ok"} { return [tk_messageBox -message $str -type $type -parent $p \ -icon question] } else { return [tk_messageBox -message $str -type $type -parent $p] } } else { # just hope that tcl will do the right thing with multibyte characters if {[string length $str] > 500000} { set str [string range $str 0 500000] append str "\n....." } return [long_message $str $type $p] } } ; # any_message ### enabling and disabling user interaction proc enable_menu_controls {yesno} { if {! $yesno} { . configure -menu .mn_empty return } . configure -menu .mn if {! $::n_updates} { .mn.pkg entryconfigure $::inx_upd_all -state disabled .mn.pkg entryconfigure $::inx_upd_tlmgr -state disabled } elseif $::need_update_tlmgr { .mn.pkg entryconfigure $::inx_upd_all -state disabled .mn.pkg entryconfigure $::inx_upd_tlmgr -state normal } else { .mn.pkg entryconfigure $::inx_upd_all -state normal .mn.pkg entryconfigure $::inx_upd_tlmgr -state disabled } if {$::tcl_platform(platform) ne "windows"} { if $::have_remote { .mn.opt entryconfigure $::inx_platforms -state normal } else { .mn.opt entryconfigure $::inx_platforms -state disabled } } }; # enable_menu_controls proc enable_widgets {yesno} { # This proc should cover all active interface elements of the main window. # But if actions are initiated via a dialog, the main window can be # deactivated simply by a grab and focus on the dialog. enable_menu_controls $yesno if $yesno { set st !disabled set ::busy "IDLE" } else { set st disabled set ::busy "BUSY" } # command entry .ent.b configure -state $st .ent.e configure -state $st # filter options # status .pkfilter.inst configure -state $st .pkfilter.alls configure -state $st .pkfilter.upd configure -state $st # detail .pkfilter.alld configure -state $st .pkfilter.coll configure -state $st .pkfilter.schm configure -state $st # mark commands .mrk_all configure -state $st .mrk_none configure -state $st # search .pksearch.e configure -state $st .pksearch.d configure -state $st # packages #.pkglist configure -state $st .pkglist state $st # final buttons .q configure -state $st .r configure -state $st .t configure -state $st .showlogs configure -state $st } ; # enable_widgets ##### tl global data ################################################## 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 {} # 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; package data stored as lists set filtered [dict create] # selecting packages for display: status and detail set stat_opt "inst" set dtl_opt "all" # searching packages for display; also search short descriptions? set search_desc 0 ##### handling tlmgr via pipe and stderr tempfile ##################### set prmpt "tlmgr>" set busy "BUSY" # 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. proc read_err_tempfile {} { set len 0 while 1 { set len [chan gets $::err l] if {$len >= 0} { lappend ::err_log $l } else { break } } } ; # read_err_tempfile proc err_exit {} { do_debug "error exit" read_err_tempfile any_message [join $::err_log "\n"] "ok" exit } ; # err_exit # Capture stdout of tlmgr into a pipe $::tlshl, # stderr into a temp file file $::err_file which is set at initialization. proc start_tlmgr {{args ""}} { # Start the TeX Live Manager shell interface. # 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 } 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 } ; # start_tlmgr proc close_tlmgr {} { catch {chan close $::tlshl} catch {chan close $::err} }; # close_tlmgr # read a line of tlmgr output proc read_line {} { # a caller of run_cmd needs to explicitly invoke 'vwait ::done_waiting' # if it wants to wait for the command to finish 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} # note. the right way to terminate is terminating the GUI shell. # This closes stdin of tlmgr shell. err_exit } elseif {$len >= 0} { # do_debug "read: $l" if $::ddebug {puts $::flid $l} if {[string first $::prmpt $l] == 0} { # prompt line: we are done with the current command enable_widgets 1 ; # this may have to be redone later # catch up with stderr read_err_tempfile if {$::pipe_cb ne ""} { do_debug "prompt found, $l" $::pipe_cb "finish" } # for vwait: set ::done_waiting 1 } else { # regular output lappend ::out_log $l if {$::pipe_cb ne ""} {$::pipe_cb "line" "$l"} } } } ; # read_line # copy error strings to error page in logs toplevel .tllg and send it to top. # This by itself does not map the logs toplevel .tllg proc show_err_log {} { #do_debug "show_err_log" .tllg.err.tx configure -state normal .tllg.err.tx delete 1.0 end if {[llength $::err_log] > 0} { foreach l $::err_log {.tllg.err.tx insert end "$l\n"} .tllg.err.tx yview moveto 1 .tllg.logs select .tllg.err } if {$::tcl_platform(os) ne "Darwin"} { # os x: text widget disabled => no selection possible .tllg.err.tx configure -state disabled } } ; # show_err_log ##### running tlmgr commands ##### # optional callback for run_cmds/read_line: set pipe_cb "" # run a list of commands proc run_cmds {cmds {cb ""}} { set ::pipe_cb $cb do_debug "run_cmds \"$cmds\"" if $::ddebug {puts $::flid "\n$cmds"} enable_widgets 0 set ::out_log {} set ::err_log {} if {$::pipe_cb ne ""} {$::pipe_cb "init"} set l [llength $cmds] for {set i 0} {$i<$l} {incr i} { set cmd [lindex $cmds $i] set ::last_cmd $cmd unset -nocomplain ::done_waiting chan puts $::tlshl $cmd chan flush $::tlshl if {$i < [expr {$l-1}]} {vwait ::done_waiting} } } ; # run_cmds # run a single command proc run_cmd {cmd {cb ""}} { run_cmds [list $cmd] $cb } ; # run_cmd proc run_cmd_waiting {cmd} { run_cmd $cmd vwait ::done_waiting } ; # run_cmd_waiting ##### callbacks for file events of tlmgr pipe ::tlshl (names *_cb) #### # callback for reading tlmgr pipe. # 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 # In init mode, it is invoked by run_cmds, otherwise by read_line ## 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"} { .tllg.log.tx configure -state normal .tllg.log.tx insert end "$l\n" if {$::tcl_platform(os) ne "Darwin"} { .tllg.log.tx configure -state disabled } } elseif {$mode eq "init"} { show_logs .tllg.status configure -text "Running" .tllg.close configure -state disabled } elseif {$mode eq "finish"} { .tllg.log.tx yview moveto 1 .tllg.logs select .tllg.log # error log on top if it contains anything show_err_log if {$::tcl_platform(os) ne "Darwin"} { .tllg.log.tx configure -state disabled } .tllg.status configure -text "Idle" .tllg.close configure -state !disabled # the caller, read_line, will set ::done_waiting after # this callback returns from finish mode } else { lappend ::err_log "Illegal call of log_widget_cb" err_exit } } ; # log_widget_cb ##### Handling package info ##### # what invokes what? # The main 'globals' are: # ::have_remote is initialized to false. It is set to true by # get_packages_info_remote, and remains true except temporarily at # a change of repository. # 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/menu states are set at initialization and updated # by update_globals, both via the enable_menu_controls proc # get_packages_info_local is invoked only once, at initialization. After # installations and removals, the collected information is updated 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_menu_controls 1 } # The package display treeview widget in the main window has columns # for both local and remote revision numbers. # It gets its data from $::filtered rather than directly from $::pkgs. # ::pkgs should already be up to date. # I added a field 'marked' to ::pkgs. It is displayed in the first treeview # column. This looks better than the treeview tag facilities. # In ::pkgs, 'marked' is represented as a boolean. # In ::filtered and .pkglist they are represented as unicode symbols. # display packages obeying both filter and search string. # even on a relatively slow system, regenerating .pkglist from ::filtered # 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 # (re)create ::filtered dictionary; disregard search string. # The value associated with each key/package is a list, not another dict. 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] set lv [dict get $pk lcatv] if {$v eq "0" || $v == 0} { set v "" } elseif {$lv != 0 && $lv ne ""} { set v "$v ($lv)" } dict lappend ::filtered $nm $v set v [dict get $pk remoterev] set rv [dict get $pk rcatv] if {$v eq "0" || $v == 0} { set v "" } elseif {$rv != 0 && $rv ne ""} { set v "$v ($rv)" } dict lappend ::filtered $nm $v dict lappend ::filtered $nm [dict get $pk shortdesc] } display_packages_info } ; # collect_filtered # 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,cat-version,category,shortdesc" set re {^([^,]+),([0-9]+),([^,]*),([^,]*),(.*)$} foreach l $::out_log { if [regexp $re $l m nm lrev lcatv 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 "lcatv" $lcatv "remoterev" 0 \ "rcatv" 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,cat-version,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 rcatv 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 yet exist, create it dict set ::pkgs $nm [list "marked" 0 "localrev" 0 "lcatv" 0] } dict set ::pkgs $nm "remoterev" $rrev dict set ::pkgs $nm "rcatv" $rcatv dict set ::pkgs $nm "category" $catg dict set ::pkgs $nm "shortdesc" $pdescr } } set ::have_remote 1 .topf.loaded configure -text "Loaded" update_globals return 1 } ; # get_packages_info_remote ## update ::pkgs after installing packages without going online again. proc update_local_revnumbers {} { do_debug "update_local_revnumbers" run_cmd_waiting "info --only-installed --data name,localrev,cat-version" set re {^([^,]+),([0-9]+),(.*)$} dict for {pk pk_dict} $::pkgs { do_debug "zeroing local data for $pk" dict set pk_dict "localrev" 0 dict set pk_dict "lcatv" 0 dict set ::pkgs $pk $pk_dict } foreach l $::out_log { if [regexp $re $l m pk lr lv] { set pk_dict [dict get $::pkgs $pk] dict set pk_dict "localrev" $lr dict set pk_dict "lcatv" $lv dict set ::pkgs $pk $pk_dict } } update_globals } ; # update_local_revnumbers ##### Dialogs and their supporting procs ############################## # look at dialog.tcl, part of Tk itself, how to implement dialog-type behavior # So far: # - logs notebook, # - maybe a toplevel for restoring packages from backup, and # - a toplevel for picking a different local or remote repository. ##### logs notebook ##### # if invoked via log_widget_cb init, it tracks progress of a tlmgr command. # log_widget_cb will temporarily disable the close button # and set .tllg.status to busy. # otherwise, it shows the output of the last completed (list of) command(s). # Note that run_cmds clears ::out_log and ::err_log, but not ::dbg_log. proc show_logs {} { toplevel .tllg -class Dialog wm withdraw .tllg set p [winfo toplevel [winfo parent .tllg]] wm transient .tllg $p wm title .tllg Logs if $::plain_unix {wm attributes .tllg -type dialog} # wallpaper pack [ttk::frame .tllg.bg] -fill both -expand 1 ttk::frame .tllg.log pack [ttk::scrollbar .tllg.log.scroll -command ".tllg.log.tx yview"] \ -side right -fill y ppack [text .tllg.log.tx -height 10 -wrap word \ -yscrollcommand ".tllg.log.scroll set"] \ -expand 1 -fill both .tllg.log.tx configure -state normal foreach l $::out_log { .tllg.log.tx insert end "$l\n" } if {$::tcl_platform(os) ne "Darwin"} {.tllg.log.tx configure -state disabled} .tllg.log.tx yview moveto 1 ttk::frame .tllg.err pack [ttk::scrollbar .tllg.err.scroll -command ".tllg.err.tx yview"] \ -side right -fill y ppack [text .tllg.err.tx -height 10 -wrap word \ -yscrollcommand ".tllg.err.scroll set"] \ -expand 1 -fill both .tllg.err.tx configure -state normal foreach l $::err_log { .tllg.err.tx configure -state normal .tllg.err.tx insert end "$l\n" } if {$::tcl_platform(os) ne "Darwin"} {.tllg.err.tx configure -state disabled} .tllg.err.tx yview moveto 1 if $::ddebug { ttk::frame .tllg.dbg pack [ttk::scrollbar .tllg.dbg.scroll -command ".tllg.dbg.tx yview"] \ -side right -fill y ppack [text .tllg.dbg.tx -height 10 -bd 2 -relief groove -wrap word \ -yscrollcommand ".tllg.dbg.scroll set"] \ -expand 1 -fill both .tllg.dbg.tx configure -state normal foreach l $::dbg_log { .tllg.dbg.tx insert end "$l\n" } if {$::tcl_platform(os) ne "Darwin"} {.tllg.dbg.tx configure -state disabled} .tllg.dbg.tx yview moveto 1 } pack [ttk::notebook .tllg.logs] -in .tllg.bg -side top -fill both -expand 1 .tllg.logs add .tllg.log -text "Output" .tllg.logs add .tllg.err -text "Errors" if $::ddebug { .tllg.logs add .tllg.dbg -text "Debug" raise .tllg.dbg .tllg.logs } raise .tllg.err .tllg.logs raise .tllg.log .tllg.logs pack [ttk::frame .tllg.bottom] -in .tllg.bg -side bottom -fill x ttk::button .tllg.close -text close -command { set p [winfo toplevel [winfo parent .tllg]] if {$p eq ""} {set p "."} raise $p; destroy .tllg} ppack .tllg.close -in .tllg.bottom -side right -anchor e ppack [ttk::label .tllg.status -anchor w] -in .tllg.bottom -side left place_dlg .tllg $p wm resizable .tllg 1 1 } ; # show_logs ##### repositories ##### 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] } ### mirrors proc edit_name {n} { set n [string tolower $n] set n [string map {" " "_"} $n] return $n } ; # edit_name 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} } ; # read_mirrors 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" -parent .tlr set inidir $::new_repo set ::new_repo "" continue } else { break } } } ; # find_local_repo proc close_repos {} { raise . destroy .tlr 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 } ; # close_repos proc repositories {} { set ::new_repo $::repo # dialog toplevel with # - popup menu of mirrors (parse tlpkg/installer/ctan-mirrors.pl) # - text entry box # - directory 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} # wallpaper frame; see make_widgets pack [ttk::frame .tlr.bg] -expand 1 -fill x pack [ttk::frame .tlr.info] -in .tlr.bg -fill x 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 # 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 # freshly create a cascading mirror dropdown 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 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 spacing .tlr.bg # two ways to close the dialog pack [ttk::frame .tlr.closebuttons] -in .tlr.bg -fill x ttk::button .tlr.save -text "Save and Load" -command close_repos ppack .tlr.save -in .tlr.closebuttons -side right ttk::button .tlr.abort -text "Abort"\ -command {raise .; destroy .tlr} ppack .tlr.abort -in .tlr.closebuttons -side right place_dlg .tlr . wm resizable .tlr 0 0 } ; # repositories ### platforms if {$::tcl_platform(platform) ne "windows"} { set ::platforms {} proc toggle_pl_marked {pl cl} { # toggle_pl_marked is triggered by a mouse click only in column #1. # 'fut' should get updated in ::platforms and in .tlpl.pl. if {$cl ne "#1"} return if {$pl eq $::our_platform} { tk_messageBox -message "Cannot remove own platform $::our_platform" \ -parent .tlpl return } # $mrk: negation of current value of marked for $pl set m1 [expr {[dict get $::platforms $pl "fut"] ? 0 : 1}] dict set ::platforms $pl "fut" $m1 set m0 [dict get $::platforms $pl "cur"] if {$m0 == $m1} { .tlpl.pl set $pl "sup" [mark_sym $m0] } else { .tlpl.pl set $pl "sup" "[mark_sym $m0] \u21d2 [mark_sym $m1]" } .tlpl.do configure -state disabled dict for {p mrks} $::platforms { if {[dict get $mrks "fut"] ne [dict get $mrks "cur"]} { .tlpl.do configure -state !disabled break } } } ; # toggle_pl_marked proc platform_do {} { raise . destroy .tlpl set pl_add {} set pl_remove {} dict for {p pd} $::platforms { if {[dict get $pd "cur"] ne [dict get $pd "fut"]} { if {[dict get $pd "fut"]} { lappend pl_add $p } else { lappend pl_remove $p } } } if {[llength $pl_add] == 0 && [llength $pl_remove] == 0} return set cmds {} if {[llength $pl_add] > 0} { set cmd "platform add " append cmd [join $pl_add " "] lappend cmds $cmd } if {[llength $pl_remove] > 0} { set cmd "platform remove " append cmd [join $pl_remove " "] lappend cmds $cmd } run_cmds $cmds log_widget_cb vwait ::done_waiting update_local_revnumbers collect_filtered } ; # platform_do proc platform_select {} { run_cmd_waiting "platform list" set ::platforms {} foreach l $::out_log { if [regexp {^\s+(\S+)$} $l m p] { dict set ::platforms $p {} dict set ::platforms $p "cur" 0 dict set ::platforms $p "fut" 0 } elseif [regexp {^\(i\)\s+(\S+)$} $l m p] { dict set ::platforms $p {} dict set ::platforms $p "cur" 1 dict set ::platforms $p "fut" 1 } } destroy .tlpl toplevel .tlpl -class Dialog wm withdraw .tlpl wm transient .tlpl . wm title .tlpl "Platforms" if $::plain_unix {wm attributes .tlpl -type dialog} # wallpaper frame pack [ttk::frame .tlpl.bg] -expand 1 -fill both # platforms treeview pack [ttk::frame .tlpl.fpl] -in .tlpl.bg -fill both -expand 1 ttk::treeview .tlpl.pl -columns {sup plat} -show headings \ -height [dict size $::platforms] ; # -yscrollcommand {.tlpl.plsb set} ppack .tlpl.pl -in .tlpl.fpl -side left -fill both -expand 1 #ttk::scrollbar .tlpl.plsb -orient vertical \ # -command {.tlpl.pl yview} #ppack .tlpl.plsb -in .tlpl.fpl -side right -fill y -expand 1 foreach col {sup plat} nm {"" "Platform"} { .tlpl.pl heading $col -text $nm -anchor w } .tlpl.pl column sup -width [expr {$::cw * 6}] .tlpl.pl column plat -width [expr {$::cw * 20}] dict for {p mks} $::platforms { .tlpl.pl insert {} end -id $p -values \ [list [mark_sym [dict get $mks "cur"]] $p] } # "#2" refers to the second column, with editable mark symbols bind .tlpl.pl {toggle_pl_marked [.tlpl.pl focus] "#1"} bind .tlpl.pl {toggle_pl_marked [.tlpl.pl focus] "#1"} # only toggle when column is "sup" i.e. #1 bind .tlpl.pl \ {toggle_pl_marked \ [.tlpl.pl identify item %x %y] \ [.tlpl.pl identify column %x %y]} # buttons pack [ttk::frame .tlpl.but] -in .tlpl.bg -fill x ttk::button .tlpl.do -text "Apply and close" -command platform_do ttk::button .tlpl.dont -text "Close" -command \ {raise .; destroy .tlpl} ppack .tlpl.do -in .tlpl.but -side right .tlpl.do configure -state disabled ppack .tlpl.dont -in .tlpl.but -side right place_dlg .tlpl . wm resizable .tlpl 0 0 } ; # platform_select } ; # $::tcl_platform(platform) ne "windows" ##### restore from backup ##### # This is currently rather dangerous. # ::do_restore is set to 0 or 1 near the top of this source. if $::do_restore { # dictionary of backups, with mapping to list of available revisions set bks {} proc enable_restore {yesno} { set st [expr {$yesno ? !disabled : disabled}] .tlbk.bklist state $st .tlbk.all configure -state $st .tlbk.done configure -state $st } ; # enable_restore proc finish_restore {} { vwait ::done_waiting # now log_widget_cb should have done finish mode # and re-enabled its close button. # We won't wait for the log toplevel to close, but we will # update the packages display in the main window. update_local_revnumbers collect_filtered } ; # finish_restore proc restore_all {} { run_cmd "restore --force --all" log_widget_cb finish_restore raise . destroy .tlbk } ; # restore_all proc restore_this {} { set id [.tlbk.bklist focus] if {$id eq {}} return set r [.tlbk.bklist set $id rev] if {$r eq {}} return set p [.tlbk.bklist set $id pkg] if {$p eq {}} { set id [.tlbk.bklist parent $id] if {$id ne {}} {set p [.tlbk.bklist set $id pkg]} } if {$p eq {}} return set ans [tk_messageBox -message "Restore $p to revision $r?" \ -type okcancel -parent .tlbk] if {$ans ne {ok}} return run_cmd "restore --force $p $r" log_widget_cb finish_restore # tkwait window .tllg } ; # restore_this proc bklist_callback_click {x y} { set cl [.tlbk.bklist identify column $x $y] if {$cl eq "#0"} return set id [.tlbk.bklist identify item $x $y] .tlbk.bklist focus $id restore_this } ; # bklist_callback_click proc restore_backups_dialog {} { run_cmd_waiting "option autobackup" set re {autobackup\t(.*)$} set abk 0 foreach l $::out_log { if [regexp $re $l m abk] break } if {$abk == 0} { tk_messageBox -message "No backups configured" return } run_cmd_waiting "option backupdir" set re {backupdir\t(.*)$} set bdir "" foreach l $::out_log { if [regexp $re $l m bdir] break } if {$bdir eq ""} { tk_messageBox -message "No backup directory defined" return } set bdir [file join [exec kpsewhich -var-value SELFAUTOPARENT] $bdir] if {! [file isdirectory $bdir]} { tk_messageBox -message "Backup directory $bdir does not exist" return } set pwd0 [pwd] cd $bdir set backups [lsort [glob *.tar.xz]] if {[llength $backups] == 0} { tk_messageBox -message "No backups found in $bdir" return } # dictionary of backups; package => list of available revisions set ::bks [dict create] set re {^(.*)\.r(\d+)\.tar\.xz$} foreach b $backups { if [regexp $re $b m pk r] { if {$pk in [dict keys $::bks]} { dict lappend ::bks $pk $r } else { dict set ::bks $pk [list $r] } } } if {[llength [dict keys $::bks]] == 0} { tk_messageBox -message "No packages in backup directory $bdir" return } # invert sort order of revisions for each package foreach pk [dict keys $::bks] { dict set ::bks $pk [lsort -decreasing [dict get $::bks $pk]] } toplevel .tlbk -class Dialog wm withdraw .tlbk wm transient .tlbk . wm title .tlbk "Restore from backup" if $::plain_unix {wm attributes .tlbk -type dialog} # wallpaper frame; see make_widgets pack [ttk::frame .tlbk.bg] -expand 1 -fill x # the displayed list of backed-up packages pack [ttk::frame .tlbk.fbk] -in .tlbk.bg -side top # package names not in #0, because we want to trigger actions # without automatically opening a parent. pack [ttk::treeview .tlbk.bklist -columns {"pkg" "rev"} \ -show {tree headings} -height 8 -selectmode browse \ -yscrollcommand {.tlbk.bkvsb set}] -in .tlbk.fbk -side left pack [ttk::scrollbar .tlbk.bkvsb -orient vertical -command \ {.tlbk.bklist yview}] -in .tlbk.fbk -side right -fill y foreach col {"pkg" "rev"} nm {"Package" "Revision"} { .tlbk.bklist heading $col -text $nm -anchor w } .tlbk.bklist column "#0" -width [expr {$::cw * 2}] .tlbk.bklist column "pkg" -width [expr {$::cw * 25}] .tlbk.bklist column "rev" -width [expr {$::cw * 12}] # fill .tlbk.bklist. Use the last available revision. # Remember that $::bks is sorted and revisions inversely sorted # id must be unique in the entire list: rev does not qualify # must as well use $id for package items too set id 0 dict for {pk rlist} $::bks { # package .tlbk.bklist insert {} end -id [incr id] \ -values [list $pk [lindex $rlist 0]] -open 0 set l [llength $rlist] # additional revisions if {$l > 1} { set idparent $id for {set i 1} {$i<$l} {incr i} { .tlbk.bklist insert $idparent end -id [incr id] \ -values [list "" [lindex $rlist $i]] } } } # since we can only restore one non-last revision at a time, it is better # to only show one non-last revision at a time too. bind .tlbk.bklist <> { foreach p [.tlbk.bklist children {}] { if {$p ne [.tlbk.bklist focus]} { .tlbk.bklist item $p -open 0 } } } # restoring a single package bind .tlbk.bklist <> {bklist_callback_click %x %y} bind .tlbk.bklist restore_this # frame with buttons pack [ttk::frame .tlbk.fbut] -in .tlbk.bg -side bottom -fill x ppack [ttk::button .tlbk.all -text "Restore all" -command restore_all] \ -in .tlbk.fbut -side right ppack [ttk::button .tlbk.done -text "Close" \ -command {raise .; destroy .tlbk}] -in .tlbk.fbut -side right place_dlg .tlbk . wm resizable .tlbk 0 0 } ; # restore_backups_dialog } ; # if $::do_restore ##### Main window and supporting procs and callbacks ################## ##### package-related ##### 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 ### doing something with some packages proc pkglist_from_option {opt {pk ""}} { if {$opt eq "marked"} { set pks {} dict for {p props} $::pkgs { if [dict get $props "marked"] {lappend pks $p} } } elseif {$opt eq "focus"} { set p [.pkglist focus] if {$p ne {}} {lappend pks $p} } elseif {$opt eq "name"} { lappend pks $pk } return $pks } ; # pkglist_from_option proc install_pkgs {sel_opt {pk ""}} { set pks [pkglist_from_option $sel_opt $pk] # check whether packages are installed set pre_installed {} set todo {} foreach p $pks { if {[dict get $::pkgs $p localrev] > 0} { lappend pre_installed $p } else { lappend todo $p } } if {[llength $todo] == 0} { tk_messageBox -message "Nothing to do!" -type ok -icon info return } run_cmd_waiting "install --dry-run $todo" # check whether dependencies are going to be installed set r {^(\S+)\s+i\s} set deps {} foreach l $::out_log { if {[regexp $r $l d p] && $p ni $pks} { lappend deps $p } } if {[llength $deps] > 0} { set ans [any_message \ "Also installing dependencies\n\n$deps.\n\nContinue?" "okcancel"] if {$ans eq "cancel"} return } run_cmd "install $todo" log_widget_cb vwait ::done_waiting if {[llength $pre_installed] > 0} { lappend ::err_log "Already installed: $pre_installed" show_err_log } update_local_revnumbers collect_filtered } ; # install_pkgs proc update_pkgs {sel_opt {pk ""}} { set pks [pkglist_from_option $sel_opt $pk] # check whether packages are installed set not_inst {} set uptodate {} set todo {} foreach p $pks { set lv [dict get $::pkgs $p localrev] if {[dict get $::pkgs $p localrev] == 0} { lappend not_inst $p } else { set rv [dict get $::pkgs $p remoterev] if {$lv >= $rv} { lappend uptodate $p } else { lappend todo $p } } } if {[llength $todo] == 0} { tk_messageBox -message "Nothing to do!" -type ok -icon info return } run_cmd_waiting "update --dry-run $todo" # check whether dependencies are going to be updated set r {^(\S+)\s+u\s} set deps {} foreach l $::out_log { if {[regexp $r $l d p] && $p ni $pks} { lappend deps $p } } if {[llength $deps] > 0} { set ans [any_message "Also updating dependencies\n\n$deps?" \ "yesnocancel"] switch $ans { "cancel" return "yes" {run_cmd "update $todo" log_widget_cb} "no" { set deps {} run_cmd_waiting "update --dry-run --no-depends $todo" foreach l $::out_log { if {[regexp $r $l u p] && $p ni $pks} { lappend deps $p } } if {[llength $deps] > 0} { set ans [any_message \ "Updating hard dependencies $deps anyway. Continue?" \ "okcancel"] if {$ans eq "cancel"} return } run_cmd "update --no-depends $todo" log_widget_cb } } } else { run_cmd "update $todo" log_widget_cb } vwait ::done_waiting if {[llength $not_inst] > 0} { lappend ::err_log "Skipped because not installed: $not_inst" } if {[llength $uptodate] > 0} { lappend ::err_log "Skipped because already up to date: $uptodate" } if {[llength $not_inst] > 0 || [llength $uptodate] > 0} { show_err_log } update_local_revnumbers collect_filtered } ; # update_pkgs proc remove_pkgs {sel_opt {pk ""}} { set pks [pkglist_from_option $sel_opt $pk] # check whether packages are installed set not_inst {} set todo {} foreach p $pks { if {[dict get $::pkgs $p localrev] > 0} { lappend todo $p } else { lappend not_inst $p } } run_cmd_waiting "remove --dry-run $todo" # check whether dependencies are going to be removed set r {^(\S+)\s+d\s} set deps {} foreach l $::out_log { if {[regexp $r $l d p] && $p ni $pks} { lappend deps $p } } if {[llength $todo] == 0} { tk_messageBox -message "Nothing to do!" -type ok -icon info return } if {[llength $deps] > 0} { set ans [any_message "Also remove dependencies\n\n$deps?" \ "yesnocancel"] switch $ans { "cancel" return "yes" {run_cmd "remove $todo" log_widget_cb} "no" { set deps {} run_cmd_waiting "remove --dry-run --no-depends $todo" foreach l $::out_log { if {[regexp $r $l d p] && $p ni $pks} { lappend deps $p } } if {[llength $deps] > 0} { set ans [any_message \ "Removing hard dependencies $deps anyway. Continue?" \ "okcancel"] if {$ans eq "cancel"} return } run_cmd "remove --no-depends $todo" log_widget_cb } } } else { run_cmd "remove $todo" log_widget_cb } vwait ::done_waiting if {[llength $not_inst] > 0} { lappend ::err_log "Skipped because not installed: $not_inst" show_err_log } update_local_revnumbers collect_filtered } ; # remove_pkgs # restoring packages is a rather different story, controlled by the # contents of the backup directory. see further up. ##### varous callbacks ##### 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 run_cmd $cmd log_widget_cb } 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 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 set m [mark_sym $mrk] dict set ::filtered $itm [lreplace [dict get $::filtered $itm] 0 0 $m] .pkglist set $itm mk $m } ; # toggle_marked proc mark_all {mrk} { foreach nm [dict keys $::pkgs] { dict set ::pkgs $nm "marked" $mrk } set m [mark_sym $mrk] 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 $m } # alternatively: regenerate ::filtered and .pkglist from ::pkgs } ; # mark_all 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}] } ##### package popup ##### proc do_package_popup_menu {x y X Y} { # as focused item, the identity of the clicked 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_cmd "info [.pkglist focus]" log_widget_cb; \ vwait ::done_waiting} if {$::have_remote && ! $::need_update_tlmgr && $rr > 0 && $lr == 0} { .pkg_popup add command -label "Install" -command \ {install_pkgs "focus"} } if {$::have_remote && ! $::need_update_tlmgr && $lr > 0 && $rr > $lr} { .pkg_popup add command -label "Update" -command \ {update_pkgs "focus"} } if {$lr > 0} { .pkg_popup add command -label "Remove" -command \ {remove_pkgs "focus"} } .pkg_popup post [expr {$X - 2}] [expr {$Y - 2}] focus .pkg_popup } ; # do_package_popup_menu proc set_paper {p} { run_cmd "paper paper $p" log_widget_cb } ##### running external commands ##### # For capturing an external command, we need a separate output channel, # but we reuse ::out_log. # stderr is bundled with stdout so ::err_log should stay empty. proc read_capt {} { set l "" ; # will contain the line to be read if {([catch {chan gets $::capt l} len] || [chan eof $::capt])} { catch {chan close $::capt} log_widget_cb "finish" set ::done_waiting 1 } elseif {$len >= 0} { lappend ::out_log $l log_widget_cb "line" $l } }; # read_capt proc run_external {cmd mess} { set ::out_log {} set ::err_log {} lappend ::out_log $mess unset -nocomplain ::done_waiting # dont understand why, on windows, start_tlmgr does not trigger # a console window but this proc does if [catch {open "|$cmd 2>&1" "r"} ::capt] { tk_messageBox -message "Failure to launch $cmd" } chan configure $::capt -buffering line -blocking 0 chan event $::capt readable read_capt log_widget_cb "init" } ##### main window ##### proc make_widgets {} { wm title . "$::progname $::procid" # width of '0', as a rough estimate of average character width set ::cw [font measure TkTextFont "0"] # dummy empty menu to replace the real menu .mn in disabled states. # the "File" cascade should ensure that the dummy menu # occupies the same vertical space as the real menu. menu .mn_empty .mn_empty add cascade -label "File" -menu .mn_empty.file -underline 0 if $::plain_unix { .mn_empty configure -borderwidth 1 .mn_empty configure -background $::default_bg menu .mn_empty.file } # real 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 -command {destroy .} -label "Exit" -underline 1 # inx: keeping count where needed, i.e. when an entry needs to be referenced .mn add cascade -label "Packages" -menu .mn.pkg menu .mn.pkg set inx 0 set ::inx_upd_tlmgr $inx .mn.pkg add command -label "Update tlmgr" -command update_tlmgr incr inx set ::inx_upd_all $inx .mn.pkg add command -label "Update all" -command update_all incr inx .mn.pkg add command -label "Install marked" \ -command {install_pkgs "marked"} incr inx .mn.pkg add command -label "Update marked" \ -command {update_pkgs "marked"} incr inx .mn.pkg add command -label "Remove marked" \ -command {remove_pkgs "marked"} if $::do_restore { incr inx .mn.pkg add command -label "Restore from backup..." \ -command restore_backups_dialog } .mn add cascade -label "Actions" -menu .mn.act -underline 0 menu .mn.act .mn.act add command -label "Regenerate filename database" -command \ {run_external "mktexlsr" "Regenerating filename database..."} .mn.act add command -label "Regenerate formats" -command \ {run_external "fmtutil-sys --all" "Rebuilding formats..."} .mn.act add command -label "Regenerate fontmaps" -command \ {run_external "updmap-sys" "Rebuilding fontmap files..."} .mn add cascade -label "Options" -menu .mn.opt -underline 0 menu .mn.opt set inx 0 .mn.opt add command -label "Change repository..." \ -command repositories incr inx .mn.opt add cascade -label "Paper" -menu .mn.opt.paper menu .mn.opt.paper foreach p [list a4 letter] { .mn.opt.paper add command -label $p -command "set_paper $p" } if {$::tcl_platform(platform) ne "windows"} { incr inx set ::inx_platforms $inx .mn.opt add command -label "Platforms..." -command platform_select } .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 # it is possible to set a background color for a toplevel, but on # MacOS I did not find a way to determine the right $::default_bg # color. Instead, all toplevels are given a wallpaper ttk::frame # with the default ttk::frame color, which seems to work # everywhere. pack [ttk::frame .bg] -expand 1 -fill both # various info ttk::frame .topf pack .topf -in .bg -side top -anchor w pgrid [ttk::label .topf.llrepo -text "Default repository" -anchor w] \ -row 0 -column 0 -sticky w pgrid [ttk::label .topf.lrepo -textvariable ::repo] \ -row 0 -column 1 -sticky w pgrid [ttk::label .topf.loaded -text "Not loaded"] \ -row 1 -column 1 -sticky w ttk::label .topf.lluptodate -text "TL Manager up to date?" -anchor w pgrid .topf.lluptodate -row 2 -column 0 -sticky w ttk::label .topf.luptodate -text "Unknown" -anchor w pgrid .topf.luptodate -row 2 -column 1 -sticky w pgrid [ttk::label .topf.llcmd -anchor w -text "Last tlmgr command: "] \ -row 3 -column 0 -sticky w pgrid [ttk::label .topf.lcmd -anchor w -textvariable ::last_cmd] \ -row 3 -column 1 -sticky w # command entry widget 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 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} -pady 3 grid [ttk::button .mrk_none -text "Mark none" -command {mark_all 0}] \ -in .pkfilter -column 2 -row 2 -sticky w -padx {50 3} -pady 3 pack .pkfilter -in .bg -side top -fill x # search interface pack [ttk::frame .pksearch] -in .bg -side top -fill x 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 ppack [ttk::checkbutton .pksearch.d -variable ::search_desc \ -text "Also search short descriptions"] -side left bind .pksearch.e display_packages_info bind .pksearch.d toggle_search_desc # packages list pack [ttk::frame .fpkg] -in .bg -side top -fill both -expand 1 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. (ver.)" "Remote Rev. (ver.)" 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 * 18}] .pkglist column remoterev -width [expr {$::cw * 18}] .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 grid rowconfigure .fpkg 0 -weight 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 "mk" i.e. #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_menu %x %y %X %Y} if $::plain_unix { bind .pkg_popup {.pkg_popup unpost} } # bottom of main window pack [ttk::frame .endbuttons] -in .bg -side bottom -fill x 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 show_logs ppack .showlogs -in .endbuttons -side right } ; # make_widgets ##### initialize ###################################################### proc initialize {} { # seed random numbers expr {srand([clock seconds])} # 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)" } # now is a good time to ask tlmgr for the tl name of our platform set ::our_platform [exec tlmgr print-platform] } # 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_menu_controls 1 }; # initialize initialize