texlive[46080] Master/texmf-dist/scripts/tlshell/tlshell.tcl: Added
commits+siepo at tug.org
commits+siepo at tug.org
Sun Dec 17 12:11:02 CET 2017
Revision: 46080
http://tug.org/svn/texlive?view=revision&revision=46080
Author: siepo
Date: 2017-12-17 12:11:02 +0100 (Sun, 17 Dec 2017)
Log Message:
-----------
Added messagebox for long messages
Modified Paths:
--------------
trunk/Master/texmf-dist/scripts/tlshell/tlshell.tcl
Modified: trunk/Master/texmf-dist/scripts/tlshell/tlshell.tcl
===================================================================
--- trunk/Master/texmf-dist/scripts/tlshell/tlshell.tcl 2017-12-17 01:22:28 UTC (rev 46079)
+++ trunk/Master/texmf-dist/scripts/tlshell/tlshell.tcl 2017-12-17 11:11:02 UTC (rev 46080)
@@ -23,13 +23,13 @@
# menus: disable tearoff feature
option add *Menu.tearOff 0
+# no bold text for messages
+option add *Dialog.msg.font TkDefaultFont userDefault
set plain_unix 0
if {$::tcl_platform(platform) eq "unix" && \
$::tcl_platform(os) ne "Darwin"} {
set plain_unix 1
}
-set any_unix 0
-if {$::tcl_platform(platform) eq "unix"} {set any_unix 1}
set test {}
set ddebug 0
@@ -136,18 +136,15 @@
set prmpt "tlmgr>"
set busy 0
-# TODO:
-# replace messagebox with a custom toplevel with a text widget
-# in case there is a lot of text
proc err_exit {} {
do_debug "error exit"
- read_err
- tk_messageBox -message [join $::err_log "\n"] -type ok -icon error
+ read_err_output
+ any_message [join $::err_log "\n"] "ok"
exit
}
-proc read_err {} {
- #do_debug "read_err"
+proc read_err_output {} {
+ #do_debug "read_err_output"
set len 0
while 1 {
set len [chan gets $::err l]
@@ -157,7 +154,7 @@
break
}
}
-}
+} ; # read_err_output
# about [chan] gets:
# if a second parameter, in this case l, is supplied
@@ -182,7 +179,7 @@
if {[string first $::prmpt $l] == 0} {
# prompt line: done with command
enable_widgets 1 ; # this may have to be redone later
- read_err
+ read_err_output
if {$::pipe_cb ne ""} {
do_debug "prompt found, $l"
$::pipe_cb "finish"
@@ -251,7 +248,7 @@
.lw.status configure -text "Running"
.lw.close configure -state disabled
wm state .lw normal
- wm deiconify .lw ;# also raises the window
+ raise .lw .
} elseif {$mode eq "finish"} {
.lw.log.tx yview moveto 1
.lw.logs select .lw.log
@@ -308,7 +305,8 @@
# The 'globals' are:
# ::have_remote is initialized to false. It is set to true by
-# get_packages_info_remote, and remains true.
+# 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
@@ -322,7 +320,7 @@
# by update_globals, both via the enable_update_buttons proc
# get_packages_info_local is invoked only once, at initialization. After
-# installations and removals, the collected information is corrected by
+# installations and removals, the collected information is updated by
# update_local_revnumbers.
# get_packages_info_remote will be invoked by collect_filtered if
@@ -617,7 +615,7 @@
### doing something with some packages
-proc pkgs_option {opt {nm ""}} {
+proc pkglist_from_option {opt {pk ""}} {
if {$opt eq "marked"} {
set pks {}
dict for {p props} $::pkgs {
@@ -627,20 +625,13 @@
set p [.pkglist focus]
if {$p ne {}} {lappend pks $p}
} elseif {$opt eq "name"} {
- lappend pks $nm
+ lappend pks $pk
}
return $pks
-} ; # pkgs_option
+} ; # pkglist_from_option
-proc after_package_changes {} {
- update_local_revnumbers
- collect_filtered
- wm state .lw normal
- place_wrt .lw .
-} ; # after_package_changes
-
proc install_pkgs {sel_opt {pk ""}} {
- set pks [pkgs_option $sel_opt $pk]
+ set pks [pkglist_from_option $sel_opt $pk]
# check whether packages are installed
set pre_installed {}
set todo {}
@@ -665,9 +656,8 @@
}
}
if {[llength $deps] > 0} {
- set ans [tk_messageBox -message \
- "Also installing dependencies $deps.\nContinue?" \
- -type yesno -icon question]
+ 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
@@ -676,11 +666,12 @@
lappend ::err_log "Already installed: $pre_installed"
show_err_log
}
- after_package_changes
+ update_local_revnumbers
+ collect_filtered
} ; # install_pkgs
proc update_pkgs {sel_opt {pk ""}} {
- set pks [pkgs_option $sel_opt $pk]
+ set pks [pkglist_from_option $sel_opt $pk]
# check whether packages are installed
set not_inst {}
set uptodate {}
@@ -702,7 +693,41 @@
tk_messageBox -message "Nothing to do!" -type ok -icon info
return
}
- run_cmd "update $todo" log_widget_cb
+ 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"
@@ -713,11 +738,12 @@
if {[llength $not_inst] > 0 || [llength $uptodate] > 0} {
show_err_log
}
- after_package_changes
+ update_local_revnumbers
+ collect_filtered
} ; # update_pkgs
proc remove_pkgs {sel_opt {pk ""}} {
- set pks [pkgs_option $sel_opt $pk]
+ set pks [pkglist_from_option $sel_opt $pk]
# check whether packages are installed
set not_inst {}
set todo {}
@@ -742,13 +768,27 @@
return
}
if {[llength $deps] > 0} {
- set ans [tk_messageBox -message \
- "Also remove dependencies $deps?" \
- -type yesnocancel -icon question]
+ set ans [any_message "Also remove dependencies\n\n$deps?" \
+ "yesnocancel"]
switch $ans {
"cancel" return
"yes" {run_cmd "remove $todo" log_widget_cb}
- "no" {run_cmd "remove --no-depends $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
@@ -758,7 +798,8 @@
lappend ::err_log "Skipped because not installed: $not_inst"
show_err_log
}
- after_package_changes
+ update_local_revnumbers
+ collect_filtered
} ; # remove_pkgs
#proc restore_pkgs {sel_opt {pk ""}} {
@@ -766,17 +807,6 @@
## package popup ##
-#proc run_package_cmd {cmd {chg 0}} {
-# set mn [.pkglist focus]
-# run_cmd "$cmd $mn" log_widget_cb
-# vwait ::done_waiting
-# if $chg {
-# do_debug "Package_cmd $cmd; should call update_local_revnumbers"
-# update_local_revnumbers
-# collect_filtered
-# }
-#} ; # run_package_cmd
-
proc do_package_popup {x y X Y} {
# as focused item, the identity of the item will be globally available:
.pkglist focus [.pkglist identify item $x $y]
@@ -835,20 +865,16 @@
if [catch {ttk::style lookup TFrame -background} ::default_bg] {
set ::default_bg white
}
-# The background color of a toplevel is 'set' by covering it
-# with a background ttk::frame.
-# Under MacOS we get the wrong answer with ttk::style lookup,
-# and the default is not right either.
# place a toplevel centered wrt its parent.
# if the geometry of the new toplevel cannot be determined,
-# its top left corner will be centered wrt its parent, which is not too bad.
+# its upperleft corner will be centered wrt its parent, which is not too bad.
proc place_wrt {wnd {p ""}} {
if {$p eq ""} {
set p [winfo [winfo toplevel parent $wnd]]
if {$p eq ""} return
}
- update ; # try to ensure that geometry info is current
+ update ; # try to make geometry info current; does not always work
set g [wm geometry $p]
scan $g "%dx%d+%d+%d" pw ph px py
set hcenter [expr $px + $pw / 2]
@@ -862,14 +888,81 @@
wm geometry $wnd [format "+%d+%d" $wx $wy]
wm attributes $wnd -topmost 1
wm attributes $p -topmost 0
- wm deiconify $wnd
+ wm state $wnd normal
raise $wnd $p
} ; # place_wrt
+
+proc long_message {str type {p "."}} {
+ # custom dialog
+ # not all 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 .lms}
+ toplevel .lms -class Dialog
+ wm withdraw .lms
+ wm transient .lms .
+ if $::plain_unix {wm attributes .lms -type dialog}
+
+ # wallpaper frame; see make_widgets:
+ pack [ttk::frame .lms.bg] -fill both -expand 1
+ ppack [ttk::frame .lms.tx] -in .lms.bg -side top -fill both -expand 1
+ pack [ttk::scrollbar .lms.tx.scroll -command ".lms.tx.txt yview"] \
+ -side right -fill y
+ ppack [text .lms.tx.txt -height 20 -width 60 -bd 2 -relief groove \
+ -wrap word -yscrollcommand ".lms.tx.scroll set"] -expand 1 -fill both
+
+ .lms.tx.txt insert end $str
+ .lms.tx.txt configure -state disabled
+
+ # buttons
+ pack [ttk::frame .lms.bts] -in .lms.bg -side bottom -fill x
+ if {$type eq "ok" || $type eq "okcancel"} {
+ ttk::button .lms.ok -text "ok" -command \
+ {raise $::lms_parent; destroy .lms; set ::lms_var "ok"}
+ ppack .lms.ok -in .lms.bts -side right
+ }
+ if {$type eq "yesnocancel"} {
+ ttk::button .lms.yes -text "yes" -command \
+ {raise $::lms_parent; destroy .lms; set::lms_var "yes"}
+ ppack .lms.yes -in .lms.bts -side right
+ ttk::button .lms.no -text "no" -command \
+ {raise $::lms_parent; destroy .lms; set ::lms_var "no"}
+ ppack .lms.no -in .lms.bts -side right
+ }
+ if {$type eq "yesnocancel" || $type eq "okcancel"} {
+ ttk::button .lms.cancel -text "cancel" -command \
+ {raise $::lms_parent; destroy .lms; set ::lms_var "cancel"}
+ ppack .lms.cancel -in .lms.bts -side right
+ }
+
+ place_wrt .lms $::lms_parent
+ grab set .lms
+ focus .lms
+ 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 {
+ return [long_message $str $type $p]
+ }
+} ; # any_message
+
proc make_widgets {} {
wm title . "$::progname $::procid"
- if $::any_unix {. configure -background $::default_bg}
# width of '0', as a rough estimate of average character width
set ::cw [font measure TkTextFont "0"]
@@ -916,9 +1009,12 @@
-label "About"
# wallpaper frame
- # it is possible to set a background color for the parent toplevel,
- # but on MacOS I did not find a way to determine the right $::default_bg.
- pack [ttk::frame .bg]
+ # 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
@@ -1043,7 +1139,8 @@
grid .pkvsb -in .fpkg -row 0 -column 1 -sticky ns
grid .pkhsb -in .fpkg -row 1 -column 0 -sticky ew
grid columnconfigure .fpkg 0 -weight 1
- pack .fpkg -in .bg -side top -expand 1
+ grid rowconfigure .fpkg 0 -weight 1
+ pack .fpkg -in .bg -side top -fill both -expand 1
# "#1" refers to the first column (with mark symbols)
bind .pkglist <space> {toggle_marked [.pkglist focus] "#1"}
@@ -1080,7 +1177,7 @@
# log displays: new toplevel, again with themed background frame
toplevel .lw
wm title .lw Logs
- pack [ttk::frame .lw.bg]
+ pack [ttk::frame .lw.bg] -fill both -expand 1
ttk::frame .lw.log
pack [ttk::scrollbar .lw.log.scroll -command ".lw.log.tx yview"] \
@@ -1133,20 +1230,22 @@
set ::new_repo $::repo
- # look at dialog.tcl how to implement dialog-type behavior
-
# toplevel with
- # - list of mirrors (parse tlpkg/installer/ctan-mirrors.pl)
- # - text entry box, or browser button
+ # - popup menu of mirrors (parse tlpkg/installer/ctan-mirrors.pl)
+ # - text entry box
+ # - directory browser button
# - ok and cancel buttons
+
+ # look at dialog.tcl how to implement dialog-type behavior
toplevel .tlr -class Dialog
wm withdraw .tlr
wm transient .tlr .
wm title .tlr "Repositories"
if $::plain_unix {wm attributes .tlr -type dialog}
- #if $::any_unix .tlr configure -background $::default_bg
- pack [ttk::frame .tlr.bg]
- pack [ttk::frame .tlr.info] -in .tlr.bg
+
+ # wallpaper frame; see make_widgets:
+ 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
@@ -1169,7 +1268,7 @@
ttk::button .tlr.ctan -text "Any CTAN mirror" \
-command {set ::new_repo "http://mirror.ctan.org/systems/texlive/tlnet"}
ppack .tlr.ctan -in .tlr.mirbuttons -side left -fill x -expand 1
- # create a cascading mirror popup menu
+ # freshly create a cascading mirror popup menu
destroy .tlr.mir.m
if {[dict size $::mirrors] == 0} read_mirrors
if {[dict size $::mirrors] > 0} {
@@ -1209,6 +1308,7 @@
place_wrt .tlr .
grab set .tlr
focus .tlr
+ wm resizable .tlr 0 0 ; # .tlr not resizable
} ; # repositories
proc close_repos {{how ""}} {
@@ -1344,7 +1444,7 @@
if {! $ok} {do_debug $msg}
} ; # read_mirrors
-proc edit_name {n} {
+proc edit_name {n} { ; # probably unnecessary
set n [string tolower $n]
set n [string map {" " "_"} $n]
return $n
More information about the tex-live-commits
mailing list