From 5425126fc2ed15ccd71373d1c826ba961ba768f6 Mon Sep 17 00:00:00 2001 From: Siep Kroonenberg Date: Sun, 17 Dec 2017 11:11:02 +0000 Subject: Added messagebox for long messages git-svn-id: svn://tug.org/texlive/trunk@46080 c570f23f-e606-0410-a88d-b1316a301751 --- Master/texmf-dist/scripts/tlshell/tlshell.tcl | 242 ++++++++++++++++++-------- 1 file changed, 171 insertions(+), 71 deletions(-) (limited to 'Master/texmf-dist') diff --git a/Master/texmf-dist/scripts/tlshell/tlshell.tcl b/Master/texmf-dist/scripts/tlshell/tlshell.tcl index aa539ac90b8..c7ef43d4dfc 100755 --- a/Master/texmf-dist/scripts/tlshell/tlshell.tcl +++ b/Master/texmf-dist/scripts/tlshell/tlshell.tcl @@ -23,13 +23,13 @@ catch {rename send {}} # 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 search_desc 0 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 @@ proc read_err {} { break } } -} +} ; # read_err_output # about [chan] gets: # if a second parameter, in this case l, is supplied @@ -182,7 +179,7 @@ proc read_line {} { 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 @@ proc log_widget_cb {mode {l ""}} { .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 @@ proc run_entry {} { # 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 @@ proc run_entry {} { # 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 @@ proc update_all {} { ### 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 @@ proc pkgs_option {opt {nm ""}} { set p [.pkglist focus] if {$p ne {}} {lappend pks $p} } elseif {$opt eq "name"} { - lappend pks $nm + lappend pks $pk } return $pks -} ; # pkgs_option - -proc after_package_changes {} { - update_local_revnumbers - collect_filtered - wm state .lw normal - place_wrt .lw . -} ; # after_package_changes +} ; # pkglist_from_option 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 @@ proc install_pkgs {sel_opt {pk ""}} { } } 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 @@ proc install_pkgs {sel_opt {pk ""}} { 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 @@ proc update_pkgs {sel_opt {pk ""}} { 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 @@ proc update_pkgs {sel_opt {pk ""}} { 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 @@ proc remove_pkgs {sel_opt {pk ""}} { 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 @@ proc remove_pkgs {sel_opt {pk ""}} { 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 @@ proc remove_pkgs {sel_opt {pk ""}} { ## 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 @@ proc notyet {} { 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 @@ proc place_wrt {wnd {p ""}} { 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 @@ proc make_widgets {} { -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 @@ proc make_widgets {} { 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 {toggle_marked [.pkglist focus] "#1"} @@ -1080,7 +1177,7 @@ proc make_widgets {} { # 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 @@ proc repositories {} { set ::new_repo $::repo - # look at dialog.tcl how to implement dialog-type behavior - # toplevel with - # - list of mirrors (parse tlpkg/installer/ctan-mirrors.pl) - # - text entry box, or browser button + # - 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 @@ proc repositories {} { 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 @@ proc repositories {} { 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 @@ proc read_mirrors {} { 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 -- cgit v1.2.3