#!/usr/bin/env wish # Copyright 2017-2023 Siep Kroonenberg # This file is licensed under the GNU General Public License version 2 # or any later version. package require Tk # security: disable send catch {rename send {}} # unix: make sure TL comes first on process searchpath # on windows, a wrapper takes care of this. if {$::tcl_platform(platform) ne "windows"} { set texbin [file dirname [file normalize [info script]]] # prepend texbin to PATH, unless it is already the _first_ # path component set dirs [split $::env(PATH) ":"] if {[lindex $dirs 0] ne $texbin} { set ::env(PATH) "${texbin}:$::env(PATH)" } unset texbin unset dirs } set ::instroot [exec kpsewhich -var-value=TEXMFROOT] set ::year 0 ; # to be set when connecting to tlmgr # try to read a configuration variable (gui-lang, tkfontscale) # from tlmgr config ($TEXMF[SYS]CONFIG/tlmgr/config # failure results in an empty string. # this proc will be invoked by tltcl if tlshell is the invoker of tltcl proc get_config_var {k} { set v "" set r [join [list {^\s*} $k {\s*=\s*(\S.*)$}] ""] foreach tmf {"TEXMFCONFIG" "TEXMFSYSCONFIG"} { if [catch {exec kpsewhich -var-value $tmf} d] { break; # apparently there is not yet a TL installation } if [catch {open [file join $d "tlmgr" "config"] r} fid] continue while 1 { if [chan eof $fid] { break } if [catch {chan gets $fid} l] break # we can assume that $k contains no special characters if [regexp $r $l m v] { set v [regsub {\s*$} $v ""] break } else { # regexp will have unset v set v "" } } chan close $fid if {$v ne ""} break } return $v } proc save_config_var {k v} { if [catch {exec kpsewhich -var-value "TEXMFCONFIG"} d] {return 0} set d [file join $d "tlmgr"] if [catch {file mkdir $d}] {return 0} ; # mkdir on existing dir is ok set fn [file join $d "config"] set oldlines [list] set r [join [list {^\s*} $k {\s*=\s*(\S.*)$}] ""] # read current config file if [file exists $fn] { if [catch {open $fn r} fid] {return 0} set cnt 0 while 1 { if [catch {chan gets $fid} l] break if [chan eof $fid] break incr cnt if {! [regexp $r $l]} { lappend oldlines $l } if {$cnt>40} break } catch {chan close $fid} } lappend oldlines "$k = $v" if [catch {open $fn w} fid] {return 0} foreach l $oldlines { if [catch {puts $fid $l}] { catch {chan close $fid} return 0 } } catch {chan close $fid} return 1 } # tltcl: declarations and utilities shared with install-tl-gui.tcl # tltcl likes to know who was the invoker set ::invoker [file tail [info script]] if [string match -nocase ".tcl" [string range $::invoker end-3 end]] { set ::invoker [string range $::invoker 0 end-4] } source [file join $::instroot "tlpkg" "tltcl" "tltcl.tcl"] # now is a good time to ask tlmgr for the _TL_ name of our platform set ::our_platform [exec -ignorestderr tlmgr print-platform] # searchpath and locale: # windows: tlshell runs via a wrapper which adjusts the searchpath # for the current process. # others: 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 should disentangle symlinks. # dis/enable the restore dialog set do_restore 0 # tlcontrib set tlcontrib "http://contrib.texlive.info/current" # dis/enable debug output (only for private development purposes) set ddebug 0 ##### general housekeeping ############################################ # menus: disable tearoff feature option add *Menu.tearOff 0 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 { if {$::tcl_platform(platform) ne "windows"} {puts stderr $s} # On windows, stderr output goes nowhere. # Therefore also debug output for the log dialog. lappend ::dbg_log $s file mkdir ${::instroot}/temp set dbg [open "${::instroot}/temp/mydbglog" a] puts $dbg "TCL: $s" chan close $dbg # Track debug output in the log dialog 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 ### temporary files and directories ######################### 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] chan 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 ##################################################### # 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 } # NOTE # text widgets aren't ttk widgets: # state disabled => configure -state disabled # state !disabled => configure -state normal # dialog with textbox 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 "Unsupported type $type for long_message" } create_dlg .tlmg $p wm title .tlmg "" # wallpaper frame; see populate_main pack [ttk::frame .tlmg.bg] -fill both -expand 1 # 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 "end_dlg \"ok\" .tlmg" ppack .tlmg.ok -in .tlmg.bts -side right } if {$type eq "yesnocancel"} { ttk::button .tlmg.yes -text [__ "Yes"] -command "end_dlg \"yes\" .tlmg" ppack .tlmg.yes -in .tlmg.bts -side right ttk::button .tlmg.no -text [__ "No"] -command "end_dlg \"no\" .tlmg" ppack .tlmg.no -in .tlmg.bts -side right } if {$type eq "yesnocancel" || $type eq "okcancel"} { ttk::button .tlmg.cancel -text [__ "Cancel"] -command \ "end_dlg \"cancel\" .tlmg" ppack .tlmg.cancel -in .tlmg.bts -side right } if [winfo exists .tlmg.cancel] { bind .tlmg {.tlmg.cancel invoke} wm protocol .tlmg WM_DELETE_WINDOW {cancel_or_destroy .tlmg.cancel .tlmg} } elseif {$type eq "ok"} { bind .tlmg {.tlmg.ok invoke} wm protocol .tlmg WM_DELETE_WINDOW {cancel_or_destroy .tlmg.ok .tlmg} } 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 # default resizable place_dlg .tlmg $p tkwait window .tlmg return $::dialog_ans } ; # 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 ##### tl global data ################################################## set ::last_cmd "" set ::progname [info script] regexp {^.*[\\/]([^\\/\.]*)(?:\....)?$} $progname dummy ::progname set ::procid [pid] # package repositories array unset ::repos # mirrors: dict of dicts of lists of urls per country per continent # moved to tltcl.tcl #set ::mirrors [dict create] # dict of (local and global) package dicts set ::pkgs [dict create] # platforms set ::platforms [dict create] set ::have_remote 0 ; # remote packages info not yet loaded set ::need_update_tlmgr 0 set ::n_updates 0 set ::tlshell_updatable 0 ## package 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 ### enabling and disabling user interaction based on global data proc selective_dis_enable {} { # disable actions which make no sense at the time # buttons in the middle section set pkg_buttons [list .mrk_inst .mrk_upd .mrk_rem .upd_tlmgr .upd_all] foreach b [list .mrk_inst .mrk_upd .mrk_rem .upd_tlmgr .upd_all] { $b state !disabled } if $::do_restore {.mrk_rest state !disabled} if {!$::have_remote} { foreach b [list .mrk_inst .mrk_upd .upd_tlmgr .upd_all] { $b state disabled } } elseif {!$::n_updates} { foreach b [list .mrk_upd .upd_tlmgr .upd_all] { $b state disabled } } elseif $::need_update_tlmgr { foreach b [list .mrk_inst .mrk_upd] { $b state disabled } if {$::tcl_platform(platform) eq "windows"} { .upd_all state disabled } } elseif {!$::need_update_tlmgr} { .upd_tlmgr state disabled } # platforms menu item if {$::tcl_platform(platform) ne "windows"} { if {!$::have_remote || $::need_update_tlmgr} { .mn.opt entryconfigure $::inx_platforms -state disabled } else { .mn.opt entryconfigure $::inx_platforms -state normal } } # 64-bit windows # we disable this menu, but we may possibly resurrect it later # for windows on arm support; therefore 'if {0 && ...} if {0 && $::tcl_platform(platform) eq "windows" && $::wprocessor eq "AMD64"} { dis_enable_w64 } }; # selective_dis_enable proc total_dis_enable {y_n} { # to be invoked when tlmgr becomes busy or idle, i.e. # if it starts with a tlmgr command through run_cmds # or read_line notices the command(s) ha(s|ve) ended. # This proc should cover all active interface elements of the main window. # But if actions are initiated via a dialog, the main window can instead # be deactivated by a grab and focus on the dialog. if {!$y_n} { ; # disable set ::busy [__ "Running"] . configure -menu .mn_empty foreach c [winfo children .] { if {$c ne ".showlogs" && [winfo class $c] in $::active_cls} { # this should cover all relevant widgets in the main window $c state disabled } } } else { ; # enable . configure -menu .mn foreach c [winfo children .] { if {[winfo class $c] in $::active_cls} { $c state !disabled } } set ::busy [__ "Idle"] selective_dis_enable } } ; # total_dis_enable ##### handling tlmgr via pipe and stderr tempfile ##################### set ::prmpt "tlmgr>" set ::busy [__ "Running"] # copy logs to log window yes/no set ::show_output 0 # 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 {} { if [info exists ::err] { 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 {{m ""}} { do_debug "error exit" read_err_tempfile if {$m ne ""} { set ::err_log [linsert $::err_log 0 $m] } 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" # -gui -. -gui-lang for {set i 0} {$i < [llength $args]} {incr i} { if {[lindex $args $i] eq "-lang"} { set args [lreplace $args $i $i "-gui-lang"] } } set cmd [list "|tlmgr" {*}$args "--machine-readable" "shell" 2>>$::err_file] if [catch {open $cmd w+} ::tlshl] { tk_messageBox -message [get_stacktrace] exit } set ::perlpid [pid $::tlshl] 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 {} { run_cmd_waiting "quit" } # 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])} { # copy as much of stderr as possible to ::err_log catch {read_err_tempfile ; chan close $::err} if [chan eof $::tlshl] { catch {chan close $::tlshl} unset -nocomplain ::tlshl unset -nocomplain ::err set ::perlpid 0 set ::done_waiting 1 } else { #do_debug "read_line: failing to read " puts stderr "Read failure; tlmgr command was $::last_cmd" # note. the normal 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 total_dis_enable 1 ; # this may have to be redone later # catch up with stderr read_err_tempfile if $::show_output { do_debug "prompt found, $l" log_widget_finish } # for vwait: set ::done_waiting 1 set ::show_output 0 } else { # regular output lappend ::out_log $l if $::show_output { log_widget_add $l } } } } ; # read_line # copy error strings to error page in logs dialog .tllg and send it to top. # This by itself does not map the logs dialog .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 proc log_widget_init {} { show_logs ; # create the logs dialog set ::busy [__ "Running"] .tllg.close state disabled } proc log_widget_add l { .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 } } proc log_widget_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 } set ::busy [__ "Idle"] .tllg.close state !disabled bind .tllg {.tllg.close invoke} } ##### running tlmgr commands ##### # run a list of commands proc run_cmds {cmds {show 0}} { set ::show_output $show do_debug "run_cmds \"$cmds\"" if $::ddebug {puts $::flid "\n$cmds"} set ::out_log {} set ::err_log {} if $show { show_logs .tllg.status configure -text [__ "Running"] .tllg.close state disabled } set l [llength $cmds] for {set i 0} {$i<$l} {incr i} { if {! [info exists ::tlshl]} { err_exit "Back end gone. Last command: \n $::last_cmd" } set cmd [lindex $cmds $i] set ::last_cmd $cmd unset -nocomplain ::done_waiting # disable widgets for each new command, # since read_line will re-enable them # when a particular command is finished total_dis_enable 0 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 {show 0}} { run_cmds [list $cmd] $show } ; # run_cmd proc run_cmd_waiting {cmd} { run_cmd $cmd 0 vwait ::done_waiting } ; # run_cmd_waiting ##### Handling package info ##### # what invokes what? # The main 'globals' are (excepting dicts and arrays): # ::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 selective_dis_enable proc # The repositories play a small part in this front end. Tlmgr mostly works # with a virtual repository, which is the combined set of repositories, # with pinning applied if there is more than one repository. # But get_packages_info_remote must invoke # show_repos to display updated verification info. # show_repos is also invoked by initialize. # get_packages_info_local is invoked only once, at initialization. After # installations and removals, the collected information is updated by # update_local_revnumbers. # Both procs also invoke get_platforms # get_packages_info_remote should be invoked before collect_filtered if # ::have_remote is false. Afterwards, ::have_remote will be true. # There will be no need to invoke get_packages_info_remote again except # at a change of repository by repos_commit. # get_packages_info_remote invokes update_globals, show_repos # and get_platforms. # 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. It invokes display_packages_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 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 display_updated_globals {} { if {$::have_remote && $::need_update_tlmgr} { .topfll.luptodate configure -text [__ "Needs updating"] } elseif $::have_remote { .topfll.luptodate configure -text [__ "Up to date"] } else { .topfll.luptodate configure -text [__ "Unknown"] } # ... and status of update buttons selective_dis_enable } proc update_globals {} { if {! $::have_remote} return set ::n_updates 0 foreach nm [dict keys $::pkgs] { if [is_updatable $nm] {incr ::n_updates} } set ::need_update_tlmgr [is_updatable texlive.infra] set ::tlshell_updatable [is_updatable tlshell] # also update displayed status info display_updated_globals } # 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 [.pkfilter.search_e get] .pkglist delete [.pkglist children {}] dict for {nm pk} $::filtered { set do_show 0 if {$curr eq ""} { # empty search string 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 for_other_platform {nm} { set r [string last "." $nm] if {$r < 0} { return 0 } else { set n [string range $nm 0 [expr {$r-1}]] set p [string range $nm [expr {$r+1}] end] # p a platform identifier of an installed platform? if [dict exists $::platforms $p] { return [expr {! [dict get $::platforms $p "cur"]}] } else { return 0 } } } # (re)create ::filtered dictionary; disregard search string in selection # 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} { # have_remote should have been ensured when changing stat_opt from inst err_exit "collect_filtered should not have been invoked at this time" } foreach nm [dict keys $::filtered] { dict unset ::filtered $nm } foreach nm [lsort [dict keys $::pkgs]] { # do not list packages for platforms which are not installed if [for_other_platform $nm] continue 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 "notins" && $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 "" ; # can this happen? } 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] } } ; # collect_filtered proc collect_and_display_filtered {} { collect_filtered display_packages_info } proc get_platforms {} { # guarantee fresh start foreach k $::platforms {dict unset ::platforms $k} set ::platforms [dict create] # find binary packages for pdftex; 'platform list' not available on windows foreach k [dict keys $::pkgs {pdftex.*}] { # {pdftex.*} is a glob pattern, not a regexp: '.' is a literal set plname [string range $k 7 end] if {[dict get $::pkgs $k localrev] > 0} { dict set ::platforms $plname "cur" 1 #dict set ::platforms $plname "fut" 1 } else { dict set ::platforms $plname "cur" 0 #dict set ::platforms $plname "fut" 0 } } } # 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_platforms } ; # get_packages_info_local proc abort_load {} { # try to close back end forcibly catch {chan close $::tlshl} if {$::tcl_platform(platform) eq "windows"} { catch {exec -ignorestderr taskkill /pid $::perlpid /t /f} } else { catch {exec -ignorestderr kill -9 $::perlpid} # should also be ok for darwin } # start new tlshell process exec $::progname & # end current tlshell process nicely exit # kill current tlshell process forcibly if necessary if {$::tcl_platform(platform) eq "windows"} { catch {exec -ignorestderr taskkill /pid [pid] /t /f} } else { catch {exec -ignorestderr kill -9 [pid]} } } ; # abort load # toplevel with abort button in case loading of a repository takes too long. # it can be closed when loading finishes proc splash_loading {} { create_dlg .loading . wm title .loading [__ "Loading"] # wallpaper pack [ttk::frame .loading.bg -padding 3pt] -fill both -expand 1 set lbl [__ \ "If loading takes too long, press Abort and choose another repository."] append lbl "\n([__ "Options"] \/ [__ "Repositories"] ...)" ppack [ttk::label .loading.l0 -text $lbl \ -wraplength [expr {60*$::cw}] -justify left] \ -in .loading.bg -anchor w pack [ttk::frame .loading.tfr] -in .loading.bg -expand 1 -fill x pack [ttk::scrollbar .loading.scroll -command ".loading.tx yview"] \ -in .loading.tfr -side right -fill y ppack [text .loading.tx -height 5 -wrap word \ -yscrollcommand ".loading.scroll set"] \ -in .loading.tfr -expand 1 -fill both pack [ttk::frame .loading.buttons] -in .loading.bg -expand 1 -fill x ttk::button .loading.close -text [__ "Close"] -command {end_dlg "" .loading} ppack .loading.close -in .loading.buttons -side right .loading.close configure -state disabled ttk::button .loading.abo -text [__ "Abort"] -command abort_load ppack .loading.abo -in .loading.buttons -side right wm protocol .loading {cancel_or_destroy .loading.abo .loading} wm resizable .loading 0 0 place_dlg .loading . } ; # splash_loading proc track_err {} { set inx0 [llength $::err_log] read_err_tempfile .loading.tx configure -state normal for {set i $inx0} {$i < [llength $::err_log]} {incr i} { .loading.tx insert end "[lindex $::err_log $i]\n" } .loading.tx configure -state disabled update idletasks if {![info exists ::loaded]} { after 500 track_err } else { .loading.close state !disabled .loading.abo state disabled .loading.tx configure -state normal .loading.tx insert end [__ "Done loading"] .loading.tx configure -state disabled } } # 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 splash_loading unset -nocomplain ::loaded track_err set catv "rcat-version" if [catch {run_cmd \ "info --data name,remoterev,$catv,category,shortdesc"}] { do_debug [get_stacktrace] tk_messageBox -message [__ "A configured repository is unavailable."] return 0 } vwait ::done_waiting set ::loaded 1 set re {^([^,]+),([0-9]+),([^,]*),([^,]*),(.*)$} foreach l $::out_log { if [regexp $re $l m nm 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 } } get_platforms ; # derive from $::pkgs set ::have_remote 1 update_globals show_repos 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,lcat-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 pk_dict "rcatv" $lv dict set ::pkgs $pk $pk_dict } } get_platforms update_globals } ; # update_local_revnumbers ##### Logs notebook ############################## # if invoked via run_cmds, it tracks progress of (a) tlmgr command(s). # run_cmds will temporarily disable the close button # and set .tllg.status to busy via total_dis_enable 0. # 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 {} { create_dlg .tllg . wm title .tllg Logs # wallpaper pack [ttk::frame .tllg.bg] -fill both -expand 1 # close button and busy label pack [ttk::frame .tllg.bottom] -in .tllg.bg -side bottom -fill x ttk::button .tllg.close -text [__ "Close"] -command {end_dlg 0 .tllg} ppack .tllg.close -in .tllg.bottom -side right -anchor e ppack [ttk::label .tllg.status -textvariable ::busy -anchor w] \ -in .tllg.bottom -side left bind .tllg {.tllg.close invoke} wm protocol .tllg WM_DELETE_WINDOW \ {cancel_or_destroy .tllg.close .tllg} # notebook pages and scrollbars 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 } # collect pages in notebook widget 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 [__ "Other"] if $::ddebug { .tllg.logs add .tllg.dbg -text "Debug" raise .tllg.dbg .tllg.logs } raise .tllg.err .tllg.logs raise .tllg.log .tllg.logs # default resizable place_dlg .tllg . } ; # show_logs ##### repositories ############################################### ### mirrors #mangle_name {n} {} ; moved to tltcl.tcl #proc read_mirrors {} {} ; moved to tltcl.tcl proc pick_local_repo {} { set nw_repo [.tlr.cur cget -text] if {! [file isdirectory $nw_repo]} { set nw_repo $::env(HOME) ; # HOME also o.k. for windows } while 1 { set nw_repo [browse4dir $nw_repo .tlr] if {$nw_repo ne "" && ! [possible_repository $nw_repo]} { tk_messageBox -message [__ "%s not a repository" $nw_repo] -parent .tlr continue } else { .tlr.save state !disabled break } } if {$nw_repo ne ""} { .tlr.new delete 0 end .tlr.new insert end $nw_repo } } ; # pick_local_repo proc get_repos_from_tlmgr {} { array unset ::repos run_cmd_waiting "option repository" set rps "" foreach l $::out_log { if [regexp {repository\t(.*)$} $l dum rps] break } if {$rps ne ""} { set reps [split $rps " "] set nr [llength $reps] foreach rp $reps { # decode spaces and % set rp [string map {"%20" " "} $rp] set rp [string map {"%25" "%"} $rp] if {! [regexp {^(.+)#(.+)$} $rp dum r t]} { # no tag; use repository as its own tag set r $rp set t $rp } if {$nr == 1} { set t "main" } set ::repos($t) $r } if {"main" ni [array names ::repos]} { array unset ::repos } } }; # get_repos_from_tlmgr proc set_repos_in_tlmgr {} { # tlmgr has no command to replace a single repository; # we need to compose a string for opt_location ourselves from $::repos. # a single repository should not get a tag. # apparently, we can safely ignore bogus pinning data. set nr [array size ::repos] set opt_repos "" set rp "" foreach nm [array names ::repos] { if {$nr==1} { if {$nm ne "main"} { err_exit "Internal error" } else { # pinning command only supported for multiple repositories set rp $::repos(main) } } else { if {$nm eq $::repos($nm)} { set rp $nm } else { set rp $::repos($nm) append rp "#$nm" } } # encode % and spaces set rp [string map {"%" "%25"} $rp] set rp [string map {" " "%20"} $rp] append opt_repos " $rp" } run_cmd_waiting "repository set [string range $opt_repos 1 end]" }; # set_repos_in_tlmgr proc show_repos {} { # this proc lists the configured repository/ies # in the upper left portion of the main window. # it makes one call to the back end, but no need to go online. set w .toprepo foreach ch [winfo children $w] {destroy $ch} set nms [array names ::repos] set c [llength $nms] grid [ttk::frame $w.repoheadframe] \ -row 0 -column 0 -columnspan 3 -sticky w pack [ttk::label $w.head -font hfont] \ -in $w.repoheadframe -side left pack [ttk::label $w.load -text ""] \ -in $w.repoheadframe -side left -anchor sw if {$c <= 0} { $w.head configure -text [__ "No repositories"] return } elseif {$c == 1} { $w.head configure -text [__ "Repository"] } else { $w.head configure -text [__ "Multiple repositories"] } if {! $::have_remote} { $w.load configure -text " ([__ "Not loaded"])" } # the $::repos array already contains the configured repositories. # 'repository status' adds verification info and actual selected mirror. set repodict [dict create] if $::have_remote { run_cmd_waiting "repository status" # a number code for verification status set re {^(\S+) (\S+)/tlpkg/texlive.tlpdb (-?\d+) (.*)$} foreach l $::out_log { if [regexp $re $l dum nm rp n d] { # dummy tag repository verification_code description # restore spaces and percent characters in nm and rp set nm [string map {"%20" " "} $nm] set nm [string map {"%25" "%"} $nm] set rp [string map {"%20" " "} $rp] set rp [string map {"%25" "%"} $rp] dict set repodict $nm "url" $rp dict set repodict $nm "vericode" $n dict set repodict $nm "veridescr" $d } } # the selected mirror is needed in the win64 code, so is a global. if {$::repos(main) eq $::any_mirror} { set ::actual_main [dict get $repodict "main" "url"] } else { set ::actual_main $::repos(main) } } set rw 0 foreach nm [array names ::repos] { incr rw pgrid [ttk::label $w.u$nm -text $::repos($nm) -justify left] \ -sticky nw -row $rw -column 0 if {$::repos($nm) eq $::any_mirror && $::have_remote} { $w.u$nm configure -text \ "$::any_mirror\n[__ "Actual repository"]:\n$::actual_main" } if {[array size ::repos] > 1 && $nm ne $::repos($nm)} { pgrid [ttk::label $w.n$nm -text "($nm)"] \ -sticky nw -row $rw -column 1 } if $::have_remote { pgrid [ttk::label $w.v$nm -text \ "verification: [dict get $repodict $nm "veridescr"]"] \ -sticky nw -row $rw -column 2 } } } ; # show_repos proc repos_commit {} { set changes 0 # set repositories then add pinning if appropriate set new_repo [forward_slashify [.tlr.new get]] if {! [regexp {^\s*$} $new_repo]} { # repository entry widget non-empty: use it if {$::repos(main) ne $new_repo} { set ::repos(main) $new_repo set changes 1 } } set had_contrib 0 if $::toggle_contrib { set changes 1 foreach nm [array names ::repos] { if {$::repos($nm) eq $::tlcontrib} { set had_contrib 1 run_cmds [list "pinning remove $nm --all" \ "pinning remove $::repos($nm) --all"] 0 vwait ::done_waiting array unset ::repos $nm } } if {! $had_contrib} { set ::repos(tlcontrib) $::tlcontrib } } if $changes { set_repos_in_tlmgr close_tlmgr start_tlmgr if {$::toggle_contrib && ! $had_contrib} { run_cmd_waiting "pinning add tlcontrib \"*\"" } } } ; # repos_commit proc dis_enable_reposave {} { if [possible_repository [.tlr.new get]] { .tlr.save state !disabled } else { .tlr.save state disabled } } proc save_load_repo {} { repos_commit end_dlg "" .tlr # reload remote package information set ::have_remote 0 get_packages_info_remote collect_and_display_filtered } proc select_mir {m} { .tlr.new delete 0 end; .tlr.new insert end $m .tlr.save state !disabled } # main repository dialog proc repository_dialog {} { # dialog with # - popup menu of mirrors (parse tlpkg/installer/ctan-mirrors.pl) # - text entry box # - directory browser button # - ok and cancel buttons create_dlg .tlr . wm title .tlr [__ "Main Repository"] # wallpaper frame; see populate_main pack [ttk::frame .tlr.bg] -expand 1 -fill x pack [ttk::frame .tlr.info] -in .tlr.bg -expand 1 -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 -text $::repos(main)] \ -in .tlr.info -row 0 -column 1 -sticky w # proposed 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] \ -in .tlr.info -row $row -column 1 -columnspan 2 -sticky ew .tlr.new insert 0 $::repos(main) bind .tlr.new dis_enable_reposave ### three ways to specify a repository ### pack [ttk::frame .tlr.mirbuttons] -in .tlr.bg -fill x # 1. default remote repository ttk::button .tlr.ctan -text [__ "Any CTAN mirror"] -command { .tlr.new delete 0 end .tlr.new insert end $::any_mirror .tlr.save state !disabled } ppack .tlr.ctan -in .tlr.mirbuttons -side left -fill x # 2. specific repository: create a cascading dropdown menu of mirrors mirror_menu .tlr.mir select_mir ppack .tlr.mir -in .tlr.mirbuttons -side left -fill x # 3. local repository ttk::button .tlr.browse -text [__ "Local directory..."] -command { .tlr.new delete 0 end; .tlr.new insert end [pick_local_repo]} ppack .tlr.browse -in .tlr.mirbuttons -side left -fill x ### add/remove tlcontrib ### ttk::label .tlr.contribt -text [__ "tlcontrib additional repository"] \ -font bfont pack .tlr.contribt -in .tlr.bg -anchor w -padx 3pt -pady [list 10pt 3pt] pack [ttk::label .tlr.contribl] -in .tlr.bg -anchor w -padx 3pt -pady 3pt ttk::checkbutton .tlr.contribb -variable ::toggle_contrib pack .tlr.contribb -in .tlr.bg -anchor w -padx 3pt -pady [list 3pt 10pt] set ::toggle_contrib 0 set has_contrib 0 foreach nm [array names ::repos] { if {$::repos($nm) eq $::tlcontrib} { set has_contrib 1 set contrib_tag $nm break } } if $has_contrib { .tlr.contribl configure -text [__ "tlcontrib repository is included"] .tlr.contribb configure -text [__ "Remove tlcontrib repository"] } else { .tlr.contribl configure -text [__ "tlcontrib repository is not included"] .tlr.contribb configure -text [__ "Add tlcontrib repository"] } # two ways to close the dialog pack [ttk::frame .tlr.closebuttons] -pady [list 10pt 0pt] -in .tlr.bg -fill x ttk::button .tlr.save -text [__ "Save and Load"] -command save_load_repo ppack .tlr.save -in .tlr.closebuttons -side right dis_enable_reposave ttk::button .tlr.cancel -text [__ "Cancel"] -command {end_dlg "" .tlr} ppack .tlr.cancel -in .tlr.closebuttons -side right bind .tlr {.tlr.cancel invoke} wm protocol .tlr WM_DELETE_WINDOW \ {cancel_or_destroy .tlr.cancel .tlr} wm resizable .tlr 1 0 place_dlg .tlr . } ; # repository_dialog ### platforms # ::platforms is a dictionary of dictionaries. # each element dictionary has keys cur and fut indicating # current and future status (i.e. being installed), # with values 0 meaning 'not installed' and 1 meaning 'installed'. # elsewhere, we shall only be interested in cur. # within the treeview list, we shall use the usual unicode mark symbols. # for windows, there is no platforms menu entry, # and the platforms dialog returns immediately, i.e. is a no-op. proc toggle_pl_marked {pl cl} { # toggle_pl_marked is triggered by a mouse click only in column #1. # 'fut'[ure] 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 %s" $::our_platform] -parent .tlpl return } set m1 [expr {[dict get $::platforms $pl "fut"] ? 0 : 1}] dict set ::platforms $pl "fut" $m1 set m0 [dict get $::platforms $pl "cur"] if {$m1 eq $m0} { .tlpl.pl tag remove "changed" $pl } else { .tlpl.pl tag add "changed" $pl } .tlpl.pl set $pl "stat" [mark_sym $m1] # any changes to apply? .tlpl.do state disabled dict for {pname pdict} $::platforms { if {[dict get $pdict "fut"] ne [dict get $pdict "cur"]} { .tlpl.do state !disabled break } } } ; # toggle_pl_marked proc platforms_commit {} { set pl_add {} set pl_remove {} dict for {pname pdict} $::platforms { if {[dict get $pdict "cur"] ne [dict get $pdict "fut"]} { if {[dict get $pdict "fut"]} { lappend pl_add $pname } else { lappend pl_remove $pname } } } 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 1 vwait ::done_waiting update_local_revnumbers collect_and_display_filtered } ; # platforms_commit # the platforms dialog proc platforms_select {} { if {$::tcl_platform(platform) eq "windows"} return create_dlg .tlpl wm title .tlpl [__ "Platforms"] if $::plain_unix {wm attributes .tlpl -type dialog} # wallpaper frame pack [ttk::frame .tlpl.bg] -expand 1 -fill both # buttons pack [ttk::frame .tlpl.but] -in .tlpl.bg -side bottom -fill x ttk::button .tlpl.do -text [__ "Apply and close"] -command { disable_dlg .tlpl platforms_commit end_dlg "" .tlpl } ttk::button .tlpl.dont -text [__ "Close"] -command \ {end_dlg "" .tlpl} ppack .tlpl.do -in .tlpl.but -side right ppack .tlpl.dont -in .tlpl.but -side left bind .tlpl {.tlpl.dont invoke} pack [ttk::label .tlpl.bold -text [__ "Changed entries are bold"] \ -font bfont] -in .tlpl.bg -side bottom # platforms treeview; do we need a scrollbar? pack [ttk::frame .tlpl.fpl] -in .tlpl.bg -fill both -expand 1 ttk::treeview .tlpl.pl -columns {stat 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 .tlpl.pl column stat -width [expr {$::cw * 3}] .tlpl.pl heading plat -text [__ "platform"] -anchor w .tlpl.pl column plat -width [expr {$::cw * 20}] # tag for indicating changed entries .tlpl.pl tag configure "changed" -font bfont dict for {pname pdict} $::platforms { dict set ::platforms $pname "fut" [dict get $pdict "cur"] } foreach pname [lsort [dict keys $::platforms]] { .tlpl.pl insert {} end -id $pname -values \ [list [mark_sym [dict get $::platforms $pname "cur"]] $pname] } set_tree_col_width .tlpl.pl "plat" 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 #1 bind .tlpl.pl \ {toggle_pl_marked \ [.tlpl.pl identify item %x %y] \ [.tlpl.pl identify column %x %y]} # enable commit button only if changes are requested .tlpl.do state disabled wm resizable .tlpl 0 1 place_dlg .tlpl . } ; # platforms_select ### paper sizes # for the simple options: proc set_all_papers {p} { run_cmd "paper paper $p" 1 } # the next few procs are for the advanced paper selection dialog proc paper_diff {} { # check for different values and update widgets accordingly set n [lindex [array names ::papers] 0] set p $::papers($n) set ::allpapers $p set ::paperchanges 0 .tlpap.do state disabled foreach nm [array names ::papers] { .tlpap.radios.$nm configure -font TkDefaultFont if {$::papers($nm) ne $p} {set ::allpapers ""} if {$::papers($nm) ne $::prevpapers($nm)} { .tlpap.radios.$nm configure -font bfont set ::paperchanges 1 .tlpap.do state !disabled } } } proc allpapers_adv {} { # ::allpapers has already been set set ::paperchanges 0 .tlpap.do state disabled foreach nm [array names ::papers] { set ::papers($nm) $::allpapers } paper_diff } proc commit_papers {} { foreach nm [array names ::papers] { if {$::papers($nm) ne $::prevpapers($nm)} { set cmd "paper $nm paper $::papers($nm)" if [catch {run_cmd_waiting $cmd} res] { puts "failed paper setting: $res" } } } # clean up no longer needed globals foreach nm [array names ::papers] {unset -nocomplain ::papers($nm)} foreach nm [array names ::prevpapers] {unset -nocomplain ::prevpapers($nm)} unset -nocomplain ::allpapers unset -nocomplain ::paperchanges } proc papersize_advanced {} { # dialog for settings paper size for: # all | pdftex | dvipdfmx | context | dvips | psutils | xdvi # on windows, xdvi is omitted # we could have handled papers somewhat like the platforms dialog, # but radio buttons seem more natural, # and there are not enough items to worry about scrollability. # we create a grid with the radio buttons and a column 'changed'. ## a non-existent engine 'dummy' to test handling of missing entries #set ::papers(dummy) "" foreach nm {"pdftex" "dvipdfmx" "context" "dvips" "psutils" "xdvi"} { set ::papers($nm) "" } if {$::tcl_platform(platform) eq "windows"} { unset -nocomplain ::papers(xdvi) } foreach nm [array names ::papers] { if {[catch {run_cmd_waiting "paper $nm paper"} ::papers($nm)] || ([llength $::err_log]<1)} { unset -nocomplain ::papers($nm) } else { set l [lindex $::err_log 0] set r [string last "): " $l] if {$r<0} { unset -nocomplain ::papers($nm) continue } else { set r [expr {$r+3}] set ::papers($nm) [string tolower [string range $l $r end]] } if {$::papers($nm) ne "a4" && $::papers($nm) ne "letter"} { set $::papers($nm) "" } } } set nms [array names ::papers] ; # invalid names have now been weeded out if {[llength $nms] < 1} { tk_messageBox -title [__ "Error"] -message [__ "No paper sizes available"] # we did not yet start building the dialog, so we can just: return } set nm0 [lindex $nms 0] set ::allpapers $::papers($nm0) foreach nm $nms { set ::prevpapers($nm) $::papers($nm) if {$::papers($nm) ne $::allpapers} {set ::allpapers ""} } set ::paperchanges 0 # build gui create_dlg .tlpap wm title .tlpap [__ "Paper sizes"] if $::plain_unix {wm attributes .tlpap -type dialog} # wallpaper frame pack [ttk::frame .tlpap.bg] -expand 1 -fill both # grid with radio buttons pack [ttk::frame .tlpap.radios] -in .tlpap.bg foreach {p c} {"a4" 1 "letter" 2} { pgrid [ttk::label .tlpap.radios.head$p \ -text [string totitle $p] -font bfont] -row 0 -column $c } grid [ttk::separator .tlpap.radios.sep0 -orient horizontal] \ -row 1 -column 0 -columnspan 3 -sticky ew pgrid [ttk::label .tlpap.radios.lall -text [__ "All"]] \ -row 2 -column 0 -sticky e foreach {p c} {"a4" 1 "letter" 2} { pgrid [ttk::radiobutton .tlpap.radios.${p}all -value $p \ -variable ::allpapers -command allpapers_adv] -row 2 -column $c } grid [ttk::separator .tlpap.radios.sep1 -orient horizontal] \ -row 3 -column 0 -columnspan 3 -sticky ew set rw 3 foreach nm $nms { incr rw pgrid [ttk::label .tlpap.radios.$nm -text $nm] \ -row $rw -column 0 -sticky e foreach {p c} {"a4" 1 "letter" 2} { pgrid [ttk::radiobutton .tlpap.radios.$p$nm -value $p \ -variable ::papers($nm) -command paper_diff] -row $rw -column $c } } incr rw grid [ttk::separator .tlpap.radios.sep2 -orient horizontal] \ -row $rw -column 0 -columnspan 3 -sticky ew # buttons pack [ttk::frame .tlpap.but] -in .tlpap.bg -side bottom -fill x ttk::button .tlpap.do -text [__ "Apply and close"] -command { disable_dlg .tlpap commit_papers end_dlg "" .tlpap } ttk::button .tlpap.dont -text [__ "Close"] -command \ {end_dlg "" .tlpap} ppack .tlpap.do -in .tlpap.but -side right ppack .tlpap.dont -in .tlpap.but -side right .tlpap.do state disabled bind .tlpap {.tlpap.dont invoke} pack [ttk::label .tlpap.bold -text [__ "Changed entries are bold"] \ -font bfont] -in .tlpap.bg -side bottom wm resizable .tlpap 0 0 place_dlg .tlpap . } ##### restore from backup ##### # This is currently rather dangerous. # ::do_restore is set to 0 or 1 near the top of this source. # This code, currently disbled, has not been tested in a while. if $::do_restore { # dictionary of backups, with mapping to list of available revisions set bks {} proc enable_restore {y_n} { set st [expr {$y_n ? !disabled : disabled}] .tlbk.bklist state $st .tlbk.all state $st .tlbk.done state $st } ; # enable_restore proc finish_restore {} { vwait ::done_waiting # now log_widget_finish should have run and re-enabled its close button. # We won't wait for the log dialog to close, but we will # update the packages display in the main window. update_local_revnumbers collect_and_display_filtered } ; # finish_restore proc restore_all {} { run_cmd "restore --force --all" 1 finish_restore } ; # 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 %s to revision %s?" $p $r] \ -type okcancel -parent .tlbk] if {$ans ne {ok}} return run_cmd "restore --force $p $r" 1 finish_restore } ; # 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 TEXMFROOT] $bdir] if {! [file isdirectory $bdir]} { tk_messageBox -message [__ "Backup directory %s does not exist" $bdir] return } set pwd0 [pwd] cd $bdir set backups [lsort [glob -nocomplain *.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 %s" $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 populate_main 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 .tlbk.bklist heading "pkg" -text [__ "Package"] -anchor w .tlbk.bklist heading "rev" -text [__ "Revision"] -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 { end_dlg "" .tlbk}] -in .tlbk.fbut -side right place_dlg .tlbk . wm resizable .tlbk 0 0 tkwait .tlbk } ; # restore_backups_dialog } ; # if $::do_restore ##### Supporting procs and callbacks ################## ##### package-related ##### ### updating proc update_tlmgr_w32 {} { close_tlmgr # don't try pipes or capturing, because of # tlmgr's acrobatics with nested command prompts wm iconify . exec -ignorestderr cmd /k "start cmd /k tlmgr update --self" exec $::progname & destroy . } proc update_tlmgr {} { if {! $::need_update_tlmgr} { tk_messageBox -message [__ "Nothing to do!"] return } if {$::tcl_platform(platform) eq "windows"} { update_tlmgr_w32 return } run_cmd "update --self" 1 vwait ::done_waiting # tlmgr restarts itself automatically update_local_revnumbers .topfr.linfra configure -text \ "tlmgr: r[dict get $::pkgs texlive.infra localrev]" collect_and_display_filtered } ; # update_tlmgr proc update_all {} { set updated_tlmgr 0 if $::need_update_tlmgr { if {$::tcl_platform(platform) eq "windows"} { return ; # just to be sure; 'update all' button should be disabled } run_cmd "update --self" 1 vwait ::done_waiting # tlmgr restarts itself automatically update_local_revnumbers set updated_tlmgr 1 } # tlmgr restarts itself automatically # tk_messageBox -message [__ "Update self first!"] # return if {! $::n_updates && !$updated_tlmgr} { tk_messageBox -message [__ "Nothing to do!"] return } elseif $::n_updates { run_cmd "update --all" 1 vwait ::done_waiting update_local_revnumbers } collect_and_display_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%s" $deps] \ "okcancel"] if {$ans eq "cancel"} return } run_cmd "install $todo" 1 vwait ::done_waiting if {[llength $pre_installed] > 0} { lappend ::err_log [__ "Already installed: %s" $pre_installed] show_err_log } update_local_revnumbers if {$sel_opt eq "marked"} unmark_all collect_and_display_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%s?" $deps] \ "yesnocancel"] switch $ans { "cancel" return "yes" {run_cmd "update $todo" 1} "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 some dependencies %s anyway. Continue?" $deps] \ "okcancel"] if {$ans eq "cancel"} return } run_cmd "update --no-depends $todo" 1 } } } else { run_cmd "update $todo" 1 } vwait ::done_waiting if {[llength $not_inst] > 0} { lappend ::err_log [__ "Skipped because not installed: %s" $not_inst] } if {[llength $uptodate] > 0} { lappend ::err_log [__ "Skipped because already up to date: %s" $uptodate] } if {[llength $not_inst] > 0 || [llength $uptodate] > 0} { show_err_log } update_local_revnumbers if {$sel_opt eq "marked"} unmark_all collect_and_display_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%s?" $deps] \ "yesnocancel"] switch $ans { "cancel" return "yes" {run_cmd "remove $todo" 1} "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 some dependencies %s anyway. Continue?" $deps] \ "okcancel"] if {$ans eq "cancel"} return } run_cmd "remove --no-depends $todo" 1 } } } else { run_cmd "remove $todo" 1 } vwait ::done_waiting if {[llength $not_inst] > 0} { lappend ::err_log "Skipped because not installed: $not_inst" show_err_log } update_local_revnumbers if {$sel_opt eq "marked"} unmark_all collect_and_display_filtered } ; # remove_pkgs # restoring packages is a rather different story, controlled by the # contents of the backup directory. see further up. ##### varous callbacks ##### 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_pkg {itm cl} { # toggle_marked_pkg 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 # clicking in the header: if {$itm eq ""} 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_pkg proc unmark_all {} { foreach nm [dict keys $::pkgs] { dict set ::pkgs $nm "marked" 0 } set m [mark_sym 0] 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 } } ; # unmark_all proc mark_displayed {} { set m [mark_sym 1] foreach nm [.pkglist children {}] { dict set ::pkgs $nm "marked" 1 dict set ::filtered $nm [lreplace [dict get $::filtered $nm] 0 0 $m] .pkglist set $nm mk $m } } ; # mark_displayed ##### 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]" 1; 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 #### gui options #### proc set_language {l} { set ::lang $l load_translations rebuild_interface if {! [save_config_var "gui-lang" $::lang]} { tk_messageBox -message [__"Cannot save language setting"] } } proc set_fontscale {s} { set ::tkfontscale $s redo_fonts rebuild_interface if {[dict get $::pkgs texlive.infra localrev] >= 54766} { if {! [save_config_var "tkfontscale" $::tkfontscale]} { tk_messageBox -message [__"Cannot save font scale setting"] } } } proc zoom {n} { if {$n <= 0} {set n 1} set_fontscale [expr {$n*$::tkfontscale}] } ##### running external commands ##### # for when a simple 'set var [exec command]' won't do # 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_capture {} { 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_finish set ::done_waiting 1 } elseif {$len >= 0} { lappend ::out_log $l log_widget_add $l } }; # read_capture proc run_external {cmd {mess ""}} { set ::out_log {} set ::err_log {} if {$mess ne ""} {lappend ::out_log $mess} unset -nocomplain ::done_waiting # treat cmd as a list, possibly of one element # using a list enables a direct invocation, bypassing a shell set cmd0 [lindex $cmd 0] set cmd [lreplace $cmd 0 0 "|$cmd0"] set cmd [list {*}$cmd 2>@1] if [catch {open $cmd r} ::capt] { tk_messageBox -message "Failure to launch $cmd" } chan configure $::capt -buffering line -blocking 0 chan event $::capt readable read_capture log_widget_init } proc about_cmd {} { set msg "\u00a9 2017-2022 Siep Kroonenberg\n\n" append msg [__ "GUI interface for TeX Live Manager\nImplemented in Tcl/Tk"] tk_messageBox -message $msg } proc tlshell_help {} { set msg \ [__ "This TeX Live Manager front-end should be pretty self-explanatory. Note that it does not cover the full functionality of tlmgr. Notably, it does not cover user mode or backup and restore. Consult the 'Tlmgr Help' menu for full documentation on tlmgr itself."] tk_messageBox -message $msg } proc tlmgr_help {} { set ::env(NOPERLDOC) 1 long_message [exec tlmgr --help] ok } ## no arbitrary commands: no way to know what data have to be updated #proc custom_command {} { # create_dlg .tlcust . # wm title .tlcust [__ "Custom command"] # pack [ttk::frame .tlcust.bg] -expand 1 -fill x # # ppack [ttk::entry .tlcust.e] \ # -in .tlcust.bg -side left -fill x -expand 1 # ppack [ttk::button .tlcust.b -text [__ "Go"] -command run_entry] \ # -in .tlcust.bg -side left # bind .tlcust.e run_entry # bind .tlcust {end_dlg "" .tlcust} # wm .tlcust resizable 1 0 # place_dlg .tlcust . #} ##### main window ##### proc try_loading_remote {} { if {[possible_repository $::repos(main)]} { get_packages_info_remote collect_and_display_filtered } else { set mes [__ "%s is not a local or remote repository. Please configure a valid repository" $::repos(main)] append mes "\n([__ "Options"] \/ [__ "Repositories"] ...)" tk_messageBox -message $mes -title [__ "Error"] -type ok -icon error } } ##### w64 binaries #################################################### # Although w64 binaries can be added if windows is only an # additional platform, the extra w64 command-prompt can only be # added from within windows. The situation is a bit difficult to # explain to begin with, so it seems better to offer the option only # for a native windows install. # I would have liked to avoid pointless downloads, # but comparing dates is fraught with problems: # - remote file info is reported differently by different protocols # - the date of a local file may be installation time # - spurious differences due to local time and daylight saving time # we CAN timestamp zipfiles to their latest member # with 'unzip -T', but this can only be done AFTER downloading. # See also tcl commands 'file mtime', and 'clock scan' if 0 { # $::wprocessor will later decide whether a w64 menu will be created. if {$::tcl_platform(platform) eq "windows"} { set ::wprocessor $::env(PROCESSOR_ARCHITECTURE) # in case of 32-bit programs on 64-bit system: if [info exists ::env(PROCESSOR_ARCHITEW6432)] { set ::wprocessor $::env(PROCESSOR_ARCHITEW6432) } } proc w64_about {} { # read and display file with warning message set fn [exec kpsewhich -format texmfscripts help-w64.txt] if {$fn eq "" || [catch {open $fn} wf]} { tk_messageBox -message "Failed to open help-w64.txt" return 0 } set s "" while {! [catch {chan gets $wf} line] && ! [chan eof $wf]} { set s [string cat $s "\n" $line] } chan close $wf long_message [string range $s 1 end] "okcancel" } set ::w64_zipdir "${::instroot}/bin/win64/zip" set ::w64_zipname "tl-win64" proc create_w64_shortcut {} { # delegate the creation of a start menu shortcut to powershell. # consider failure non-fatal set shortcutfile \ [file join \ [expr {$::multiuser ? $::env(programdata) : $::env(appdata)}] \ "microsoft\\windows\\start menu\\programs" \ "TeX Live $::year" \ "TeX Live $::year 64-bit.lnk"] set shortcut_bsl [string map {\/ \\} $shortcutfile] set inst_bsl [string map {\/ \\} $::instroot] set path_add "${inst_bsl}\\bin\\win64;${inst_bsl}\\bin\\win32;" # below, escape '%' for the sake of tcl, probably unnecessary here # i believe '%' has no special significance for powershell. set shargs "/k path ${path_add}\%PATH\% && title TeX Live 64-bit" set cmd [string cat \ "\$ws = new-object -comobject wscript.shell;" \ "\$s = \$ws.createshortcut('$shortcut_bsl');" \ "\$s.targetpath = 'cmd';" \ "\$s.arguments = '$shargs';" \ "\$s.workingdirectory = '\%userprofile\%';" \ "\$s.save()"] # powershell will silently overwrite an existing shortcut set res [catch {exec cmd /c powershell.exe -NoLogo -NonInteractive \ -NoProfile -command $cmd}] if {$res || ![file exists $shortcutfile]} { return 0 } return 1 } proc remove_w64 {} { total_dis_enable 0 update idletasks # remove shortcut set shortcutfile \ [file join \ [expr {$::multiuser ? $::env(programdata) : $::env(appdata)}] \ "microsoft\\windows\\start menu\\programs" \ "TeX Live $::year" \ "TeX Live $::year 64-bit.lnk"] file delete -force $shortcutfile cd $::instroot set w64dir [file join $::instroot "bin" "win64"] total_dis_enable 1 update idletasks catch {file delete -force $w64dir} if {[file exists $shortcutfile] || [file exists $w64dir]} { tk_messageBox -message "$w64dir not completely removed" dis_enable_w64 return 0 } else { tk_messageBox -message "$w64dir completely removed" dis_enable_w64 return 1 } } proc make_64_dirs {} { if [catch {file mkdir "$::instroot/bin/win64/zip"}] { tk_messageBox -message "Cannot create required directory" return 0 } return 1 } # local or remote source: these are separate submenu entries proc get_remote_w64 {} { set curl "$::instroot/tlpkg/installer/curl/curl.exe" set url "" if {[string first {://} $::repos(main)]<0} { # local repository, we assume w64 not included set url "" } elseif $::have_remote { set url $::actual_main } else { set url $::repos(main) if {$url eq $::any_mirror} { set url "" } } # we are currently in $::w64_zipdir if [file exists ${::w64_zipname}.zip] { # here and elsewhere, we do not consider a rename failure fatal catch {file rename -force ${::w64_zipname}.zip ${::w64_zipname}_old.zip} } set notfound 1 set ntries 1 while {$notfound && $ntries<6} { if {$url eq ""} { # ask curl for a specific mirror if [catch {exec $curl -Ls -o nul -w %{url_effective} $::any_mirror} url] { tk_messageBox -message "Cannot get any mirror" return 0 } } set c [string last "/texlive" $url] if {$c<0} { lappend ::err_log "Mirror $url no good at try $ntries" continue } set url [string range $url 0 $c] ; # the new value includes a final '/' set url "${url}win32/TLW64/${::w64_zipname}.zip" # download options: # -s: silent; -f: silent fail; -o: target name; -R: preserve time incr ntries set notfound [catch { exec -keepnewline -ignorestderr $curl -s -f -o ${::w64_zipname}.zip -R $url }] if {!$notfound} { lappend ::err_log "Success after $ntries tries" return 1 } else { set url "" } } tk_messageBox -message \ "No success after $ntries tries.\nFailed to download ${::w64_zipname}.zip" return 0 } proc get_local_w64 {} { # we are currently in $::w64_zipdir # invoke file browser set zipfile [tk_getOpenFile \ -filetypes {{"Zip files" {.zip .ZIP}}} \ -initialfile "${::w64_zipname}.zip" \ -title "Zipfile with 64-bit binaries"] if {$zipfile eq ""} { return 0 } else { if {[file normalize $zipfile] ne "${::w64_zipdir}/${::w64_zipname}.zip"} { # nothing to be done if zipfile is at its intended location if [file exists "${::w64_zipname}.zip"] { file rename -force "${::w64_zipname}.zip" "${::w64_zipname}_old.zip" # ignore failure; below, we shall just try to overwrite } if [catch {file copy -force $zipfile ${::w64_zipname}.zip}] { tk_messageBox -message \ "Cannot copy $zipfile to ${::w64_zipdir}/${::w64_zipname}.zip" return 0 } } } return 1 } proc dis_enable_w64 {} { if [file exists [file join $::instroot "bin" "win64"]] { .mn.w64 entryconfigure $::inx_remove64 -state normal } else { .mn.w64 entryconfigure $::inx_remove64 -state disabled } if [file exists [file join $::w64_zipdir "${::w64_zipname}.zip"]] { .mn.w64 entryconfigure $::inx_sync64 -state normal } else { .mn.w64 entryconfigure $::inx_sync64 -state disabled } } proc sync_w64_w32 {} { # disable interface, but only if invoked directly set caller [lindex [info level 1] 0] if {$caller ne "add_or_update_w64"} { total_dis_enable 0 update idletasks } # try to clear out bin/win64 foreach f [glob -nocomplain -directory $::instroot/bin/win64 *] { if {![file isdirectory $f]} { catch {file delete $f} } } cd $::instroot; # actually already done by invoker if [catch { exec unzip -d $::instroot -qo ${::w64_zipdir}/${::w64_zipname}.zip} r] { tk_messageBox -message "$r:\nDid not succeed in extracting all win64 files" return 0 } cd $::instroot/bin/win64 # all 64-bit executable files should have corresponding 32-bit files set sync_mess {} foreach f [glob -nocomplain *] { # exempt .dll files if {[string tolower [string range $f end-3 end]] ne ".dll"} { if {! [file exists ../win32/$f] && ![file isdirectory $f]} { if [catch {file delete $f}] { lappend sync_mess $f } } } } cd $::instroot if {$caller ne "add_or_update_w64"} { total_dis_enable 1 update idletasks } return $sync_mess } proc add_or_update_w64 {lr} { if {! [file exists ${::w64_zipname}.zip]} { # 'about' message if no prior w64 w64_about } set ok 1 # below, fatal errors in invoked procs produce error message boxes # so nothing remains but abandoning the effort. if {! [make_64_dirs]} {set ok 0} if {$ok && [catch {cd $::w64_zipdir}]} { tk_messageBox -message "Cannot access $::w64_zipdir" set ok 0 } if {! $ok} {return 0} # operations below may take time: disable interface total_dis_enable 0 update idletasks if {$lr eq "remote"} { if {! [get_remote_w64]} { set ok 0 } } else { if {! [get_local_w64]} { set ok 0 } } if $ok { # unpack new zip selectively set mess [sync_w64_w32] ; # a list of filenames if {[llength $mess]>0} { set mess [linsert $mess 0 \ "The following files should have been deleted from bin/w64 but were not:"] } # now w64 shortcut for cmd.exe using powershell invocation if [create_w64_shortcut] { lappend mess "64-bit TeXLive shortcut created" } else { lappend mess "Failed to create 64-bit TeXLive shortcut" } lappend mess "Downloaded and installed 64-bit binaries." lappend mess "Done" any_message [join $mess "\n"] ok } total_dis_enable 1 update idletasks return 1 } }; # if 0 ##### main window ##################################################### proc populate_main {} { wm withdraw . wm title . "TeX Live Shell" ## menu ## # 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 0 .mn_empty configure -background $::default_bg menu .mn_empty.file } # real menu menu .mn . configure -menu .mn if $::plain_unix { .mn configure -borderwidth 0 .mn configure -background $::default_bg # plain_unix: avoid a possible RenderBadPicture error on quitting # when there is a menu. # 'send' bypasses the bug by changing the shutdown sequence. # 'tk appname ' restores 'send'. bind . { catch {tk appname appname} } } .mn add cascade -label [__ "File"] -menu .mn.file -underline 0 menu .mn.file .mn.file add command -label [__ "Load repository"] \ -command try_loading_remote .mn.file add command -command {destroy .} -label [__ "Exit"] -underline 1 .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.act add command -label [__ "Custom command"] -command custom_command .mn add cascade -label [__ "Options"] -menu .mn.opt -underline 0 # need to keep track of indices of this submenu menu .mn.opt set inx -1 incr inx .mn.opt add command -label "[__ "Repositories"] ..." \ -command repository_dialog incr inx .mn.opt add cascade -label [__ "Paper ..."] -menu .mn.opt.paper incr inx menu .mn.opt.paper foreach p {A4 Letter} { .mn.opt.paper add command -label $p -command \ "set_all_papers [string tolower $p]" } .mn.opt.paper add command -label "[__ "Advanced"] ..." \ -command papersize_advanced if {$::tcl_platform(platform) ne "windows"} { incr inx set ::inx_platforms $inx .mn.opt add command -label "[__ "Platforms"] ..." -command platforms_select } if {0 && $::tcl_platform(platform) eq "windows" && $::wprocessor eq "AMD64"} { .mn add cascade -label "64-bit Windows" -menu .mn.w64 menu .mn.w64 set inx -1 incr inx .mn.w64 add command -label [__ "About"] -command w64_about incr inx .mn.w64 add command -label [__ "Add/replace 64-bit binaries"] \ -command "add_or_update_w64 remote" incr inx .mn.w64 add command -label [__ "Add/replace from local file"] \ -command "add_or_update_w64 local" incr inx set ::inx_sync64 $inx .mn.w64 add command -label [__ "Resynchronize with 32-bit"] \ -command sync_w64_w32 incr inx set ::inx_remove64 $inx .mn.w64 add command -label [__ "Remove 64-bit binaries"] \ -command remove_w64 } if {[llength $::langs] > 1} { .mn add cascade -label [__ "GUI language"] \ -menu .mn.lang menu .mn.lang foreach l [lsort $::langs] { if {$l eq $::lang} { set mlabel "$l *" } else { set mlabel $l } .mn.lang add command -label $mlabel \ -command "set_language $l" } } .mn add cascade -label [__ "GUI font scaling"] \ -menu .mn.fscale menu .mn.fscale .mn.fscale add command -label \ "[__ "Current:"] [format {%.2f} $::tkfontscale]" foreach s {0.6 0.8 1 1.2 1.6 2 2.5 3 3.8 5 6 7.5 9} { .mn.fscale add command -label $s -command "set_fontscale $s" } # browser-style keyboard shortcuts for scaling bind . {zoom 0.8} bind . {zoom 1.25} bind . {zoom 1.25} bind . {zoom 1.25} bind . {set_fontscale 1} if {$::tcl_platform(os) eq "Darwin"} { bind . {zoom 0.8} bind . {zoom 1.25} bind . {zoom 1.25} bind . {zoom 1.25} bind . {set_fontscale 1} } .mn add cascade -label [__ "Help"] -menu .mn.help -underline 0 menu .mn.help .mn.help add command -label [__ "About"] -command about_cmd .mn.help add command -label [__ "TLShell Help"] -command tlshell_help .mn.help add command -label [__ "Tlmgr Help"] -command tlmgr_help ## menu end # 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 .bg configure -padding 5pt # bottom of main window pack [ttk::frame .endbuttons] -in .bg -side bottom -fill x ttk::label .busy -textvariable ::busy -font hfont -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 # top of main window ppack [ttk::frame .topf] -in .bg -side top -anchor w -fill x if $::ddebug { ppack [ttk::label .topf.test -text [info nameofexecutable]] ppack [ttk::label .topf.test2 -text $::progname] ppack [ttk::label .topf.test3 -text \ [string range $::env(PATH) 0 59]] } # left info frame pack [ttk::frame .topfl] -in .topf -side left -anchor nw # subframe for repositories, to be filled by show_repos pack [ttk::frame .toprepo] -in .topfl -side top -anchor w # various info (left frame) pack [ttk::frame .topfll] -in .topfl -side top -anchor nw -pady {6pt 0pt} ttk::label .topfll.lluptodate -text [__ "TL Manager up to date?"] -anchor w pgrid .topfll.lluptodate -row 2 -column 0 -sticky w ttk::label .topfll.luptodate -text [__ "Unknown"] -anchor w pgrid .topfll.luptodate -row 2 -column 1 -sticky w ttk::label .topfll.llcmd -text [__ "Last tlmgr command:"] -anchor w pgrid .topfll.llcmd -row 3 -column 0 -sticky w ttk::label .topfll.lcmd -textvariable ::last_cmd \ -wraplength [expr {60*$::cw}] -justify left -anchor w pgrid .topfll.lcmd -row 3 -column 1 -sticky w # right info frame ppack [ttk::frame .topfr] -in .topf -side right -anchor ne if {$::tcl_platform(platform) eq "windows"} { pack [ttk::label .topfr.ladmin] -side top -anchor e } pack [ttk::label .topfr.lroot] -side top -anchor e .topfr.lroot configure -text [__ "Root at %s" $::instroot] pack [ttk::label .topfr.linfra] -side top -anchor e pack [ttk::label .topfr.lshell] -side top -anchor e pack [ttk::separator .sp -orient horizontal] \ -in .bg -side top -fill x -pady 3pt # controls frame, between info frame and package list pack [ttk::frame .middle] -in .bg -side top -fill x pack [ttk::frame .pkcontrol] \ -in .middle -side left -anchor nw -fill x # package list display options ttk::label .lpack -text [string toupper [__ "Package list"]] \ -font hfont pack .lpack -in .pkcontrol -side top -padx 3pt -pady {6pt 6pt} -anchor w pack [ttk::frame .pkfilter -relief groove -borderwidth 2 -padding 3pt] \ -in .pkcontrol -side top -anchor nw # on my current linux, groove works only with a dimensionless borderwidth # separator columns grid columnconfigure .pkfilter 1 -minsize 20pt grid [ttk::separator .pkfilter.sep1 -orient vertical] \ -column 1 -row 0 -rowspan 5 -sticky ns grid columnconfigure .pkfilter 3 -minsize 20pt grid [ttk::separator .pkfilter.sep3 -orient vertical] \ -column 3 -row 0 -rowspan 5 -sticky ns # filter on status: inst, all, upd ttk::label .pkfilter.lstat -font bfont -text [__ "Status"] ttk::radiobutton .pkfilter.inst -text [__ "Installed"] -value inst \ -variable ::stat_opt -command collect_and_display_filtered ttk::radiobutton .pkfilter.notins -text [__ "Not installed"] -value notins \ -variable ::stat_opt -command { if {! $::have_remote} get_packages_info_remote collect_and_display_filtered } ttk::radiobutton .pkfilter.alls -text [__ "All"] -value all \ -variable ::stat_opt -command { if {! $::have_remote} get_packages_info_remote collect_and_display_filtered } ttk::radiobutton .pkfilter.upd -text [__ "Updatable"] -value upd \ -variable ::stat_opt -command { if {! $::have_remote} get_packages_info_remote collect_and_display_filtered } grid .pkfilter.lstat -column 0 -row 0 -sticky w -padx {3pt 50pt} pgrid .pkfilter.inst -column 0 -row 1 -sticky w pgrid .pkfilter.notins -column 0 -row 2 -sticky w pgrid .pkfilter.alls -column 0 -row 3 -sticky w pgrid .pkfilter.upd -column 0 -row 4 -sticky w # filter on detail level: all, coll, schm ttk::label .pkfilter.ldtl -font bfont -text [__ "Detail >> Global"] ttk::radiobutton .pkfilter.alld -text [__ All] -value all \ -variable ::dtl_opt -command collect_and_display_filtered ttk::radiobutton .pkfilter.coll -text [__ "Collections and schemes"] \ -value coll -variable ::dtl_opt -command collect_and_display_filtered ttk::radiobutton .pkfilter.schm -text [__ "Only schemes"] -value schm \ -variable ::dtl_opt -command collect_and_display_filtered pgrid .pkfilter.ldtl -column 2 -row 0 -sticky w pgrid .pkfilter.alld -column 2 -row 1 -sticky w pgrid .pkfilter.coll -column 2 -row 2 -sticky w pgrid .pkfilter.schm -column 2 -row 3 -sticky w # search interface ttk::label .pkfilter.search_l -font bfont -text [__ "Search"] ttk::entry .pkfilter.search_e -width 30 ttk::radiobutton .pkfilter.search_n -variable ::search_desc \ -value 0 -text [__ "By name"] ttk::radiobutton .pkfilter.search_d -variable ::search_desc \ -value 1 -text [__ "By name and description"] pgrid .pkfilter.search_l -column 4 -row 0 -sticky w pgrid .pkfilter.search_e -column 4 -row 1 -sticky w pgrid .pkfilter.search_n -column 4 -row 2 -sticky w pgrid .pkfilter.search_d -column 4 -row 3 -sticky w bind .pkfilter.search_e display_packages_info bind .pkfilter.search_n \ {set ::search_desc 0; display_packages_info} bind .pkfilter.search_d \ {set ::search_desc 1; display_packages_info} # actions pack [ttk::frame .pkact] -in .middle -side right -anchor ne ttk::button .mrk_inst -text [__ "Install marked"] -command { install_pkgs "marked"} ppack .mrk_inst -in .pkact -side top -fill x ttk::button .mrk_upd -text [__ "Update marked"] -command { update_pkgs "marked"} ppack .mrk_upd -in .pkact -side top -fill x ttk::button .mrk_rem -text [__ "Remove marked"] -command { remove_pkgs "marked"} ppack .mrk_rem -in .pkact -side top -fill x if $::do_restore { ttk::button .mrk_rest -text "[__ "Restore from backup"] ..." -command \ restore_backups_dialog ppack .mrk_rest -in .pkact -side top -fill x } ttk::button .upd_tlmgr -text [__ "Update tlmgr"] -command update_tlmgr ppack .upd_tlmgr -in .pkact -side top -fill x ttk::button .upd_all -text [__ "Update all"] -command update_all ppack .upd_all -in .pkact -side top -fill x # marking all/none pack [ttk::frame .pksel] \ -in .bg -pady 6pt -side top -fill x pack [ttk::button .mrk_all -text [__ "Mark all displayed"] \ -command mark_displayed] -in .pksel -side left pack [ttk::button .mrk_none -text [__ "Mark none"] -command unmark_all] \ -in .pksel -padx 6pt -side left ttk::label .binwarn \ -text [__ "Only packages for installed platforms are displayed"] pack .binwarn -in .pksel -padx 3pt -side right -anchor s # packages list itself 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 \ -yscrollcommand {.pkvsb set} .pkglist heading mk -text "" -anchor w .pkglist heading name -text [__ "Name"] -anchor w .pkglist heading localrev -text [__ "Local rev. (ver.)"] -anchor w .pkglist heading remoterev -text [__ "Remote rev. (ver.)"] -anchor w .pkglist heading shortdesc -text [__ "Description"] -anchor w .pkglist column mk -width [expr {$::cw * 3}] -stretch 0 # column widths are resizable: no need to accommodate the longest names .pkglist column name -width [expr {$::cw * 25}] -stretch 1 .pkglist column localrev -width [expr {$::cw * 18}] -stretch 0 .pkglist column remoterev -width [expr {$::cw * 18}] -stretch 0 .pkglist column shortdesc -width [expr {$::cw * 50}] -stretch 1 ttk::scrollbar .pkvsb -orient vertical -command {.pkglist yview} ppack .pkglist -in .fpkg -side left -expand 1 -fill both ppack .pkvsb -in .fpkg -side left -fill y # "#1" refers to the first column (with mark symbols) bind .pkglist {toggle_marked_pkg [.pkglist focus] "#1"} bind .pkglist {toggle_marked_pkg [.pkglist focus] "#1"} # only toggle when column is "mk" i.e. #1 bind .pkglist {toggle_marked_pkg [ .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} } wm protocol . WM_DELETE_WINDOW {cancel_or_destroy .q .} wm resizable . 1 1 wm state . normal raise . } proc display_all_data {} { # (re)display all data if {$::tcl_platform(platform) eq "windows"} { .topfr.ladmin configure -text \ [expr {$::multiuser ? [__ "Multi-user"] : [__ "Single-user"]}] } # revision numbers for tlmgr and tlshell .topfr.linfra configure -text \ "tlmgr: r[dict get $::pkgs texlive.infra localrev]" .topfr.lshell configure -text \ "tlshell: r[dict get $::pkgs tlshell localrev]" show_repos display_packages_info display_updated_globals } # to be invoked at initialization and after a font scaling- or language change proc rebuild_interface {} { foreach c [winfo children .] {catch {destroy $c}} # for busy/idle indicators set ::busy [__ "Idle"] populate_main display_all_data if {$::tcl_platform(platform) eq "windows"} {wm deiconify .} } ##### initialize ###################################################### proc initialize {} { # seed random numbers expr {srand([clock seconds])} # 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] } # store language in tlmgr configuration save_config_var "gui-lang" $::lang # in case we are going to do something with json: # add json subdirectory to auto_path, but at low priority # since the tcl/tk installation may already have a better implementation. # Trust 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"] populate_main # testing writablilty earlier led to sizing problems if {! [dir_writable $::instroot]} { set ans [tk_messageBox -type yesno -icon warning -message \ [__ "%s is not writable. You can probably not do much. Are you sure you want to continue?" $::instroot]] if {$ans ne "yes"} {exit} } # handle -h[elp] and -v[ersion parameters; # do not pass these on to the upcoming tlmgr pipe set i $::argc while 1 { incr i -1 if {$i<0} break set s [lindex $::argv $i] if {$s eq "-h" || $s eq "-help"} { tk_messageBox -message [__ "See internal help"] \ -icon info -type ok set ::argv [lreplace $::argv $i $i] } elseif {$s eq "-v" || $s eq "-version"} { set ::argv [lreplace $::argv $i $i] } } set ::argc [llength $::argv] start_tlmgr {*}$::argv if {$::tcl_platform(platform) eq "windows"} { run_cmd_waiting "option multiuser" set ::multiuser 0 foreach l $::out_log { if [regexp {^\s*multiuser\s+([01])\s*$} $l d ::multiuser] break } } run_cmd_waiting "version" foreach l $::out_log { if {[string range $l 0 8] eq "tlversion"} { set ::year [string range $l end-3 end] break } } get_packages_info_local collect_filtered get_repos_from_tlmgr display_all_data }; # initialize initialize