You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
778 lines
22 KiB
778 lines
22 KiB
#!/usr/bin/env wish
|
|
|
|
# Copyright 2018-2020 Siep Kroonenberg
|
|
|
|
# This file is licensed under the GNU General Public License version 2
|
|
# or any later version.
|
|
|
|
# common declarations for tlshell.tcl and install-tl-gui.tcl
|
|
|
|
set ::plain_unix 0
|
|
if {$::tcl_platform(platform) eq "unix" && $::tcl_platform(os) ne "Darwin"} {
|
|
set ::plain_unix 1
|
|
}
|
|
|
|
if $::plain_unix {
|
|
# plain_unix: avoid a RenderBadPicture error on quitting.
|
|
# 'send' changes the shutdown sequence,
|
|
# which avoids triggering the bug.
|
|
# 'tk appname <something>' restores 'send' and avoids the bug
|
|
bind . <Destroy> {
|
|
catch {tk appname appname}
|
|
}
|
|
}
|
|
|
|
# process ID of the perl program that will run in the background
|
|
set ::perlpid 0
|
|
|
|
# mirrors
|
|
|
|
set any_mirror "http://mirror.ctan.org/systems/texlive/tlnet"
|
|
|
|
# turn name into a string suitable for a widget name
|
|
proc mangle_name {n} {
|
|
set n [string tolower $n]
|
|
set n [string map {" " "_"} $n]
|
|
return $n
|
|
} ; # mangle_name
|
|
|
|
set mirrors [dict create]
|
|
proc read_mirrors {} {
|
|
if [catch {open [file join $::instroot \
|
|
"tlpkg/installer/ctan-mirrors.pl"] r} fm] {
|
|
return 0
|
|
}
|
|
set re_geo {^\s*'([^']+)' => \{\s*$}
|
|
set re_url {^\s*'(.*)' => ([0-9]+)}
|
|
set re_clo {^\s*\},?\s*$}
|
|
set starting 1
|
|
set lnum 0 ; # line number for error messages
|
|
set ok 1 ; # no errors encountered yet
|
|
set countries {} ; # aggregate list of countries
|
|
set urls {} ; # aggregate list of urls
|
|
set continent ""
|
|
set country ""
|
|
set u ""
|
|
set in_cont 0
|
|
set in_coun 0
|
|
while {! [catch {chan gets $fm} line] && ! [chan eof $fm]} {
|
|
incr lnum
|
|
if $starting {
|
|
if {[string first "\$mirrors =" $line] == 0} {
|
|
set starting 0
|
|
continue
|
|
} else {
|
|
set ok 0
|
|
set msg "Unexpected line '$line' at start"
|
|
break
|
|
}
|
|
}
|
|
# starting is now dealt with.
|
|
if [regexp $re_geo $line dummy c] {
|
|
if {! $in_cont} {
|
|
set in_cont 1
|
|
set continent $c
|
|
set cont_dict [dict create]
|
|
if {$continent in [dict keys $::mirrors]} {
|
|
set ok 0
|
|
set msg "Duplicate continent $c at line $lnum"
|
|
break
|
|
}
|
|
} elseif {! $in_coun} {
|
|
set in_coun 1
|
|
set country $c
|
|
if {$country in $countries} {
|
|
set ok 0
|
|
set msg "Duplicate country $c at line $lnum"
|
|
break
|
|
}
|
|
lappend countries $country
|
|
dict set cont_dict $country {}
|
|
} else {
|
|
set ok 0
|
|
set msg "Unexpected continent- or country line $line at line $lnum"
|
|
break
|
|
}
|
|
} elseif [regexp $re_url $line dummy u n] {
|
|
if {! $in_coun} {
|
|
set ok 0
|
|
set msg "Unexpected url line $line at line $lnum"
|
|
break
|
|
} elseif {$n ne "1"} {
|
|
continue
|
|
}
|
|
append u "systems/texlive/tlnet"
|
|
if {$u in $urls} {
|
|
set ok 0
|
|
set msg "Duplicate url $u at line $lnum"
|
|
break
|
|
}
|
|
dict lappend cont_dict $country $u
|
|
lappend urls $u
|
|
set u ""
|
|
} elseif [regexp $re_clo $line] {
|
|
if $in_coun {
|
|
set in_coun 0
|
|
set country ""
|
|
} elseif $in_cont {
|
|
set in_cont 0
|
|
dict set ::mirrors $continent $cont_dict
|
|
set continent ""
|
|
} else {
|
|
break ; # should close mirror list
|
|
}
|
|
} ; # ignore other lines
|
|
}
|
|
close $fm
|
|
} ; # read_mirrors
|
|
|
|
# cascading dropdown mirror menu
|
|
# parameter cmd should be a proc which does something with the selected url
|
|
proc mirror_menu {wnd cmd} {
|
|
destroy $wnd.m
|
|
if {[dict size $::mirrors] == 0} read_mirrors
|
|
if {[dict size $::mirrors] > 0} {
|
|
ttk::menubutton $wnd -text [__ "Specific mirror..."] \
|
|
-direction below -menu $wnd.m
|
|
menu $wnd.m
|
|
dict for {cont d_cont} $::mirrors {
|
|
set c_ed [mangle_name $cont]
|
|
menu $wnd.m.$c_ed
|
|
$wnd.m add cascade -label $cont -menu $wnd.m.$c_ed
|
|
dict for {cntr urls} $d_cont {
|
|
set n_ed [mangle_name $cntr]
|
|
menu $wnd.m.$c_ed.$n_ed
|
|
$wnd.m.$c_ed add cascade -label $cntr -menu $wnd.m.$c_ed.$n_ed
|
|
foreach u $urls {
|
|
$wnd.m.$c_ed.$n_ed add command -label $u -command "$cmd $u"
|
|
}
|
|
}
|
|
}
|
|
} else {
|
|
ttk::label $wnd -text [__ "No mirror list available"]
|
|
}
|
|
return $wnd
|
|
}
|
|
|
|
proc possible_repository {s} {
|
|
if [regexp {^(https?|ftp):\/\/.+} $s] {return 1}
|
|
if {[string first {file://} $s] == 0} {set s [string range $s 7 end]}
|
|
if [file isdirectory [file join $s "archive"]] {return 1}
|
|
if [file isdirectory [file join $s "texmf-dist/web2c"]] {return 1}
|
|
return 0
|
|
}
|
|
|
|
proc get_stacktrace {} {
|
|
set level [info level]
|
|
set s ""
|
|
for {set i 1} {$i < $level} {incr i} {
|
|
append s [format "Level %u: %s\n" $i [info level $i]]
|
|
}
|
|
return $s
|
|
} ; # get_stacktrace
|
|
|
|
proc normalize_argv {} {
|
|
# work back to front, to not disturb indices of unscanned list elements
|
|
set i $::argc
|
|
while 1 {
|
|
incr i -1
|
|
if {$i<0} break
|
|
set s [lindex $::argv $i]
|
|
if {[string range $s 0 1] eq "--"} {
|
|
set s [string range $s 1 end]
|
|
#set ::argv [lreplace $::argv $i $i $s]
|
|
lset ::argv $i $s
|
|
}
|
|
set j [string first "=" $s]
|
|
if {$j > 0} {
|
|
set s0 [string range $s 0 [expr {$j-1}]]
|
|
set s1 [string range $s [expr {$j+1}] end]
|
|
set ::argv [lreplace $::argv $i $i $s0 $s1]
|
|
} elseif {$j==0} {
|
|
err_exit "Command-line argument $s starting with \"=\""
|
|
} ; # else leave alone
|
|
}
|
|
set ::argc [llength $::argv]
|
|
}
|
|
normalize_argv
|
|
|
|
# localization support
|
|
|
|
# for the sake of our translators we use our own translation function
|
|
# which can use .po files directly. This allows them to check their work
|
|
# without creating or waiting for a conversion to .msg.
|
|
# We still use the msgcat module for detecting default locale.
|
|
# Otherwise, the localization code borrows much from Norbert Preining's
|
|
# translation module for TL.
|
|
|
|
package require msgcat
|
|
|
|
# available languages
|
|
set ::langs [list "en"]
|
|
foreach l [glob -nocomplain -directory \
|
|
[file join $::instroot "tlpkg" "translations"] *.po] {
|
|
lappend ::langs [string range [file tail $l] 0 end-3]
|
|
}
|
|
|
|
proc initialize_language {} {
|
|
# check the command-line for a lang parameter
|
|
set ::lang ""
|
|
set i 0
|
|
while {$i < $::argc} {
|
|
set p [lindex $::argv $i]
|
|
incr i
|
|
if {$p eq "-lang" || $p eq "-gui-lang"} {
|
|
if {$i < $::argc} {
|
|
set ::lang [lindex $::argv $i]
|
|
break
|
|
}
|
|
}
|
|
}
|
|
unset i
|
|
|
|
# First fallback, only for tlshell: check tlmgr config file
|
|
if {$::lang eq "" && [info exists ::invoker] && $::invoker eq "tlshell"} {
|
|
set ::lang [get_config_var "gui-lang"]
|
|
}
|
|
|
|
# try to set tcltk's locale to $::lang too. this may not work for 8.5.
|
|
if {$::lang ne ""} {::msgcat::mclocale $::lang}
|
|
|
|
# second fallback: what does msgcat think about it? Note that
|
|
# msgcat checks the environment and on windows also the registry.
|
|
if {$::lang eq ""} {set ::lang [::msgcat::mclocale]}
|
|
|
|
set messcat ""
|
|
if {$::lang ne ""} {
|
|
set messcat ""
|
|
set maybe ""
|
|
set ::lang [string tolower $::lang]
|
|
set tdir [file join $::instroot "tlpkg" "translations"]
|
|
foreach f [glob -nocomplain -directory $tdir *.po] {
|
|
set ln_f [string tolower [string range [file tail $f] 0 end-3]]
|
|
if {$ln_f eq $::lang} {
|
|
set messcat $f
|
|
break
|
|
} elseif {[string range $ln_f 0 1] eq [string range $::lang 0 1]} {
|
|
set maybe $f
|
|
}
|
|
}
|
|
if {$messcat eq "" && $maybe ne ""} {
|
|
set ::lang [string tolower [string range [file tail $maybe] 0 end-3]]
|
|
}
|
|
}
|
|
}
|
|
initialize_language
|
|
|
|
proc load_translations {} {
|
|
foreach s [array names ::TRANS] {
|
|
array unset ::TRANS $s
|
|
}
|
|
if {$::lang eq ""} return
|
|
set messcat [file join $::instroot "tlpkg" "translations" "${::lang}.po"]
|
|
# parse messcat.
|
|
# skip lines which make no sense
|
|
if [file exists $messcat] {
|
|
# create array with msgid keys and msgstr values
|
|
# in the case that we switch languages,
|
|
# we need to remove old translations,
|
|
# since the new set may not completely cover the old one
|
|
if {! [catch {open $messcat r} fid]} {
|
|
fconfigure $fid -encoding utf-8
|
|
set inmsgid 0
|
|
set inmsgstr 0
|
|
set msgid ""
|
|
set msgstr ""
|
|
while 1 {
|
|
if [chan eof $fid] break
|
|
if [catch {chan gets $fid} l] break
|
|
if [regexp {^\s*#} $l] continue
|
|
if [regexp {^\s*$} $l] {
|
|
# empty line separates msgid/msgstr pairs
|
|
if $inmsgid {
|
|
# msgstr lines missing
|
|
# puts stderr "no translation for $msgid in $messcat"
|
|
set msgid ""
|
|
set msgstr ""
|
|
set inmsgid 0
|
|
set inmsgstr 0
|
|
continue
|
|
}
|
|
if $inmsgstr {
|
|
# empty line signals end of msgstr
|
|
if {$msgstr ne ""} {
|
|
set msgid [string map {{\n} "\n"} $msgid]
|
|
set msgstr [string map {{\n} "\n"} $msgstr]
|
|
set msgid [string map {{\\} "\\"} $msgid]
|
|
set msgstr [string map {{\\} "\\"} $msgstr]
|
|
set msgid [string map {{\"} "\""} $msgid]
|
|
set msgstr [string map {{\"} "\""} $msgstr]
|
|
set ::TRANS($msgid) $msgstr
|
|
}
|
|
set msgid ""
|
|
set msgstr ""
|
|
set inmsgid 0
|
|
set inmsgstr 0
|
|
continue
|
|
}
|
|
continue
|
|
} ; # empty line
|
|
if [regexp {^msgid\s+"(.*)"\s*$} $l m msgid] {
|
|
# note. a failed match will leave msgid alone
|
|
set inmsgid 1
|
|
continue
|
|
}
|
|
if [regexp {^"(.*)"\s*$} $l m s] {
|
|
if $inmsgid {
|
|
append msgid $s
|
|
} elseif $inmsgstr {
|
|
append msgstr $s
|
|
}
|
|
continue
|
|
}
|
|
if [regexp {^msgstr\s+"(.*)"\s*$} $l m msgstr] {
|
|
set inmsgstr 1
|
|
set inmsgid 0
|
|
}
|
|
}
|
|
chan close $fid
|
|
}
|
|
}
|
|
}
|
|
load_translations
|
|
|
|
proc __ {s args} {
|
|
if {[info exists ::TRANS($s)]} {
|
|
set s $::TRANS($s)
|
|
#} else {
|
|
# puts stderr "No translation found for $s\n[get_stacktrace]"
|
|
}
|
|
if {$args eq ""} {
|
|
return $s
|
|
} else {
|
|
return [format $s {*}$args]
|
|
}
|
|
}
|
|
|
|
# string representation of booleans
|
|
proc yes_no {b} {
|
|
if $b {
|
|
set ans [__ "Yes"]
|
|
} else {
|
|
set ans [__ "No"]
|
|
}
|
|
return $ans
|
|
}
|
|
|
|
# avoid warnings from tar and perl about locale
|
|
set ::env(LC_ALL) "C"
|
|
unset -nocomplain ::env(LANG)
|
|
unset -nocomplain ::env(LANGUAGE)
|
|
|
|
### fonts ###
|
|
|
|
# ttk defaults use TkDefaultFont and TkHeadingFont
|
|
# ttk classic theme also uses TkTextFont for TEntry
|
|
# ttk::combobox uses TkTextFont
|
|
# although only the first three appear to be used here, this may depend
|
|
# on the theme, so I resize all symbolic fonts anyway.
|
|
|
|
set dflfonts [list \
|
|
TkHeadingFont \
|
|
TkCaptionFont \
|
|
TkDefaultFont \
|
|
TkMenuFont \
|
|
TkTextFont \
|
|
TkTooltipFont \
|
|
TkFixedFont \
|
|
TkIconFont \
|
|
TkSmallCaptionFont \
|
|
]
|
|
foreach f $::dflfonts {
|
|
set ::oldsize($f) [font configure $f -size]
|
|
}
|
|
|
|
font create bfont
|
|
font create lfont
|
|
font create hfont
|
|
font create titlefont
|
|
|
|
proc redo_fonts {} {
|
|
|
|
# note that ttk styles refer to the above symbolic font names
|
|
# and generally do not define fonts themselves
|
|
|
|
foreach f $::dflfonts {
|
|
font configure $f -size [expr { round($::oldsize($f)*$::tkfontscale)}]
|
|
}
|
|
# the above works for ttk::*button, ttk::treeview, notebook labels
|
|
unset -nocomplain f
|
|
|
|
option add *font TkDefaultFont
|
|
# the above works for menu items, ttk::label, text, ttk::entry
|
|
# including current value of ttk::combobox, ttk::combobox list items
|
|
# and non-ttk labels and buttons - which are not used here
|
|
# apparently, these widget classes use the X11 default font on Linux.
|
|
|
|
set ::cw \
|
|
[expr {max([font measure TkDefaultFont "0"],[font measure TkTextFont "0"])}]
|
|
# height: assume height == width*2
|
|
# workaround for treeview on windows on HiDPI displays
|
|
ttk::style configure Treeview -rowheight [expr {3 * $::cw}]
|
|
|
|
# no bold text for messages; `userDefault' indicates priority
|
|
option add *Dialog.msg.font TkDefaultFont userDefault
|
|
|
|
# normal size bold
|
|
font configure bfont {*}[font configure TkDefaultFont]
|
|
font configure bfont -weight bold
|
|
# larger, not bold: lfont
|
|
font configure lfont {*}[font configure TkDefaultFont]
|
|
font configure lfont -size [expr {round(1.2 * [font actual lfont -size])}]
|
|
# larger and bold
|
|
font configure hfont {*}[font configure lfont]
|
|
font configure hfont -weight bold
|
|
# extra large and bold
|
|
font configure titlefont {*}[font configure TkDefaultFont]
|
|
font configure titlefont -weight bold \
|
|
-size [expr {round(1.5 * [font actual titlefont -size])}]
|
|
}
|
|
|
|
# initialize scaling factor
|
|
|
|
set ::tkfontscale ""
|
|
if {[info exists ::invoker] && $::invoker eq "tlshell"} {
|
|
set ::tkfontscale [get_config_var "tkfontscale"]
|
|
# is $::tkfontscale a number, and a reasonable one?
|
|
if {[scan $::tkfontscale {%f} f] != 1} { ; # not a number
|
|
set ::tkfontscale ""
|
|
} elseif {$::tkfontscale < 0} {
|
|
set ::tkfontscale ""
|
|
} elseif {$::tkfontscale < 0.5} {
|
|
set ::tkfontscale 0.5
|
|
} elseif {$::tkfontscale > 10} {
|
|
set ::tkfontscale 10
|
|
}
|
|
}
|
|
if {$::tkfontscale eq ""} {
|
|
if {[winfo vrootheight .] > 2000 && [winfo vrootwidth .] > 3000} {
|
|
set ::tkfontscale 2
|
|
} else {
|
|
set ::tkfontscale 1
|
|
}
|
|
}
|
|
redo_fonts
|
|
|
|
# icon
|
|
catch {
|
|
image create photo tl_logo -file \
|
|
[file join $::instroot "tlpkg" "tltcl" "tlmgr.gif"]
|
|
wm iconphoto . -default tl_logo
|
|
}
|
|
|
|
# default foreground color and disabled foreground color
|
|
# may not be black in e.g. dark color schemes
|
|
set blk [ttk::style lookup TButton -foreground]
|
|
set gry [ttk::style lookup TButton -foreground disabled]
|
|
|
|
# 'default' padding
|
|
|
|
proc ppack {wdg args} { ; # pack command with padding
|
|
pack $wdg {*}$args -padx 3 -pady 3
|
|
}
|
|
|
|
proc pgrid {wdg args} { ; # grid command with padding
|
|
grid $wdg {*}$args -padx 3 -pady 3
|
|
}
|
|
|
|
# unicode symbols as fake checkboxes in ttk::treeview widgets
|
|
|
|
proc mark_sym {mrk} {
|
|
if {$::tcl_platform(platform) eq "windows"} {
|
|
# under windows, these look slightly better than
|
|
# the non-windows selections
|
|
if $mrk {
|
|
return "\u2714" ; # 'heavy check mark'
|
|
} else {
|
|
return "\u25CB" ; # 'white circle'
|
|
}
|
|
} else {
|
|
if $mrk {
|
|
return "\u25A3" ; # 'white square containing black small square'
|
|
} else {
|
|
return "\u25A1" ; # 'white square'
|
|
}
|
|
}
|
|
} ; # mark_sym
|
|
|
|
# for help output
|
|
set ::env(NOPERLDOC) 1
|
|
|
|
##### dialog support #####
|
|
|
|
# for example code, look at dialog.tcl, part of Tk itself
|
|
|
|
# In most cases, it is not necessary to explicitly define a handler for
|
|
# the WM_DELETE_WINDOW protocol. But if the cancel- or abort button would do
|
|
# anything special, then the close icon should not bypass this.
|
|
|
|
# widget classes which can be enabled and disabled.
|
|
# The text widget class is not included here.
|
|
|
|
set ::active_cls [list TButton TCheckbutton TRadiobutton TEntry Treeview]
|
|
|
|
# global variable for dialog return value, in case the outcome
|
|
# must be handled by the caller rather than by the dialog itself:
|
|
set ::dialog_ans {}
|
|
|
|
# start new toplevel with settings appropriate for a dialog
|
|
proc create_dlg {wnd {p .}} {
|
|
unset -nocomplain ::dialog_ans
|
|
catch {destroy $wnd} ; # no error if it does not exist
|
|
toplevel $wnd -class Dialog
|
|
wm withdraw $wnd
|
|
if [winfo viewable $p] {wm transient $wnd $p}
|
|
if $::plain_unix {wm attributes $wnd -type dialog}
|
|
}
|
|
|
|
# Place a dialog centered wrt its parent.
|
|
# If its geometry is somehow not yet available,
|
|
# its upperleft corner will be centered.
|
|
|
|
proc place_dlg {wnd {p "."}} {
|
|
update idletasks
|
|
set g [wm geometry $p]
|
|
scan $g "%dx%d+%d+%d" pw ph px py
|
|
set hcenter [expr {$px + $pw / 2}]
|
|
set vcenter [expr {$py + $ph / 2}]
|
|
set g [wm geometry $wnd]
|
|
set wh [winfo reqheight $wnd]
|
|
set ww [winfo reqwidth $wnd]
|
|
set wx [expr {$hcenter - $ww / 2}]
|
|
if {$wx < 0} { set wx 0}
|
|
set wy [expr {$vcenter - $wh / 2}]
|
|
if {$wy < 0} { set wy 0}
|
|
wm geometry $wnd [format "+%d+%d" $wx $wy]
|
|
update idletasks
|
|
wm state $wnd normal
|
|
raise $wnd $p
|
|
tkwait visibility $wnd
|
|
focus $wnd
|
|
grab set $wnd
|
|
} ; # place_dlg
|
|
|
|
# in case pressing the closing button leads to lengthy processing:
|
|
proc disable_dlg {wnd} {
|
|
foreach c [winfo children $wnd] {
|
|
if {[winfo class $c] in $::active_cls} {
|
|
catch {$c state disabled}
|
|
}
|
|
}
|
|
}
|
|
|
|
proc end_dlg {ans wnd} {
|
|
set ::dialog_ans $ans
|
|
set p [winfo parent $wnd]
|
|
if {$p eq ""} {set p "."}
|
|
raise $p
|
|
destroy $wnd
|
|
} ; # end_dlg
|
|
|
|
# a possibly useful callback for WM_DELETE_WINDOW
|
|
proc cancel_or_destroy {ctrl topl} {
|
|
if [winfo exists $ctrl] {
|
|
$ctrl invoke
|
|
} elseif [winfo exists $topl] {
|
|
destroy $topl
|
|
}
|
|
}
|
|
|
|
##### directories #####
|
|
|
|
# slash flipping
|
|
proc forward_slashify {s} {
|
|
regsub -all {\\} $s {/} r
|
|
return $r
|
|
}
|
|
proc native_slashify {s} {
|
|
if {$::tcl_platform(platform) eq "windows"} {
|
|
regsub -all {/} $s {\\} r
|
|
} else {
|
|
regsub -all {\\} $s {/} r
|
|
}
|
|
return $r
|
|
}
|
|
|
|
# test whether a directory is writable.
|
|
# 'file writable' merely tests permissions, which may not be good enough
|
|
proc dir_writable {d} {
|
|
for {set x 0} {$x<100} {incr x} {
|
|
set y [expr {int(10000*rand())}]
|
|
set newfile [file join $d $y]
|
|
if [file exists $newfile] {
|
|
continue
|
|
} else {
|
|
if [catch {open $newfile w} fid] {
|
|
return 0
|
|
} else {
|
|
chan puts $fid "hello"
|
|
chan close $fid
|
|
if [file exists $newfile] {
|
|
file delete $newfile
|
|
return 1
|
|
} else {
|
|
return 0
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return 0
|
|
}
|
|
|
|
# unix: choose_dir replacing native directory browser
|
|
|
|
if {$::tcl_platform(platform) eq "unix"} {
|
|
|
|
# Based on the directory browser from the tcl/tk widget demo.
|
|
# Also for MacOS, because we want to see /usr.
|
|
# For windows, the native browser widget is better.
|
|
|
|
## Code to populate a single directory node
|
|
proc populateTree {tree node} {
|
|
if {[$tree set $node type] ne "directory"} {
|
|
set type [$tree set $node type]
|
|
return
|
|
}
|
|
$tree delete [$tree children $node]
|
|
foreach f [lsort [glob -nocomplain -directory $node *]] {
|
|
set type [file type $f]
|
|
if {$type eq "directory"} {
|
|
$tree insert $node end \
|
|
-id $f -text [file tail $f] -values [list $type]
|
|
# Need at least one child to make this node openable,
|
|
# will be deleted when actually populating this node
|
|
$tree insert $f 0 -text "dummy"
|
|
}
|
|
}
|
|
# Stop this code from rerunning on the current node
|
|
$tree set $node type processedDirectory
|
|
}
|
|
|
|
proc choose_dir {initdir {parent .}} {
|
|
|
|
create_dlg .browser $parent
|
|
wm title .browser [__ "Browse..."]
|
|
|
|
# wallpaper
|
|
pack [ttk::frame .browser.bg -padding 3] -fill both -expand 1
|
|
|
|
# ok and cancel buttons
|
|
pack [ttk::frame .browser.fr1] \
|
|
-in .browser.bg -side bottom -fill x
|
|
ppack [ttk::button .browser.ok -text [__ "Ok"]] \
|
|
-in .browser.fr1 -side right
|
|
ppack [ttk::button .browser.cancel -text [__ "Cancel"]] \
|
|
-in .browser.fr1 -side right
|
|
bind .browser <Escape> {.browser.cancel invoke}
|
|
wm protocol .browser WM_DELETE_WINDOW \
|
|
{cancel_or_destroy .browser.cancel .browser}
|
|
.browser.ok configure -command {
|
|
set ::dialog_ans [.browser.tree focus]
|
|
destroy .browser
|
|
}
|
|
.browser.cancel configure -command {
|
|
set ::dialog_ans ""
|
|
destroy .browser
|
|
}
|
|
|
|
## Create the tree and set it up
|
|
pack [ttk::frame .browser.fr0] -in .browser.bg -fill both -expand 1
|
|
set tree [ttk::treeview .browser.tree \
|
|
-columns {type} -displaycolumns {} -selectmode browse \
|
|
-yscroll ".browser.vsb set"]
|
|
.browser.tree column 0 -stretch 1
|
|
ttk::scrollbar .browser.vsb -orient vertical -command "$tree yview"
|
|
# hor. scrolling does not work, but toplevel and widget are resizable
|
|
$tree heading \#0 -text "/"
|
|
$tree insert {} end -id "/" -text "/" -values [list "directory"]
|
|
|
|
populateTree $tree "/"
|
|
bind $tree <<TreeviewOpen>> {
|
|
populateTree %W [%W focus]
|
|
}
|
|
bind $tree <ButtonRelease-1> {
|
|
.browser.tree heading \#0 -text [%W focus]
|
|
}
|
|
|
|
## Arrange the tree and its scrollbar in the toplevel
|
|
# Horizontal scrolling does not work, but resizing does.
|
|
grid $tree -in .browser.fr0 -row 0 -column 0 -sticky nsew
|
|
grid .browser.vsb -in .browser.fr0 -row 0 -column 1 -sticky ns
|
|
grid columnconfigure .browser.fr0 0 -weight 1
|
|
grid rowconfigure .browser.fr0 0 -weight 1
|
|
unset -nocomplain ::dialog_ans
|
|
|
|
# navigate tree to $initdir
|
|
set chosenDir {}
|
|
foreach d [file split [file normalize $initdir]] {
|
|
set nextdir [file join $chosenDir $d]
|
|
if [file isdirectory $nextdir] {
|
|
if {! [$tree exists $nextdir]} {
|
|
$tree insert $chosenDir end -id $nextdir \
|
|
-text $d -values [list "directory"]
|
|
}
|
|
populateTree $tree $nextdir
|
|
set chosenDir $nextdir
|
|
} else {
|
|
break
|
|
}
|
|
}
|
|
$tree see $chosenDir
|
|
$tree selection set [list $chosenDir]
|
|
$tree focus $chosenDir
|
|
$tree heading \#0 -text $chosenDir
|
|
|
|
place_dlg .browser $parent
|
|
tkwait window .browser
|
|
return $::dialog_ans
|
|
}; # choose_dir
|
|
|
|
}; # if unix
|
|
|
|
proc browse4dir {inidir {parent .}} {
|
|
if {$::tcl_platform(platform) eq "unix"} {
|
|
return [choose_dir $inidir $parent]
|
|
} else {
|
|
return [tk_chooseDirectory \
|
|
-initialdir $inidir -title [__ "Select or type"] -parent $parent]
|
|
}
|
|
} ; # browse4dir
|
|
|
|
# browse for a directory and store in entry- or label widget $w
|
|
proc dirbrowser2widget {w} {
|
|
set wclass [winfo class $w]
|
|
if {$wclass eq "Entry" || $wclass eq "TEntry"} {
|
|
set is_entry 1
|
|
} elseif {$wclass eq "Label" || $wclass eq "TLabel"} {
|
|
set is_entry 0
|
|
} else {
|
|
err_exit "browse2widget invoked with unsupported widget class $wclass"
|
|
}
|
|
if $is_entry {
|
|
set retval [$w get]
|
|
} else {
|
|
set retval [$w cget -text]
|
|
}
|
|
set retval [browse4dir $retval [winfo parent $w]]
|
|
if {$retval eq ""} {
|
|
return 0
|
|
} else {
|
|
if {$wclass eq "Entry" || $wclass eq "TEntry"} {
|
|
$w delete 0 end
|
|
$w insert 0 $retval
|
|
} else {
|
|
$w configure -text $retval
|
|
}
|
|
return 1
|
|
}
|
|
}
|
|
|