"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tltcl/tltcl.tcl" (31 May 2020, 22132 Bytes) of package /linux/misc/install-tl-unx.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Tcl/Tk source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 #!/usr/bin/env wish
    2 
    3 # Copyright 2018-2020 Siep Kroonenberg
    4 
    5 # This file is licensed under the GNU General Public License version 2
    6 # or any later version.
    7 
    8 # common declarations for tlshell.tcl and install-tl-gui.tcl
    9 
   10 set ::plain_unix 0
   11 if {$::tcl_platform(platform) eq "unix" && $::tcl_platform(os) ne "Darwin"} {
   12   set ::plain_unix 1
   13 }
   14 
   15 if $::plain_unix {
   16   # plain_unix: avoid a RenderBadPicture error on quitting.
   17   # 'send' changes the shutdown sequence,
   18   # which avoids triggering the bug.
   19   # 'tk appname <something>' restores 'send' and avoids the bug
   20   bind . <Destroy> {
   21     catch {tk appname appname}
   22   }
   23 }
   24 
   25 # process ID of the perl program that will run in the background
   26 set ::perlpid 0
   27 
   28 # mirrors
   29 
   30 set any_mirror "http://mirror.ctan.org/systems/texlive/tlnet"
   31 
   32 # turn name into a string suitable for a widget name
   33 proc mangle_name {n} {
   34   set n [string tolower $n]
   35   set n [string map {" "  "_"} $n]
   36   return $n
   37 } ; # mangle_name
   38 
   39 set mirrors [dict create]
   40 proc read_mirrors {} {
   41   if [catch {open [file join $::instroot \
   42                    "tlpkg/installer/ctan-mirrors.pl"] r} fm] {
   43     return 0
   44   }
   45   set re_geo {^\s*'([^']+)' => \{\s*$}
   46   set re_url {^\s*'(.*)' => ([0-9]+)}
   47   set re_clo {^\s*\},?\s*$}
   48   set starting 1
   49   set lnum 0 ; # line number for error messages
   50   set ok 1 ; # no errors encountered yet
   51   set countries {} ; # aggregate list of countries
   52   set urls {} ; # aggregate list of urls
   53   set continent ""
   54   set country ""
   55   set u ""
   56   set in_cont 0
   57   set in_coun 0
   58   while {! [catch {chan gets $fm} line] && ! [chan eof $fm]} {
   59     incr lnum
   60     if $starting {
   61       if {[string first "\$mirrors =" $line] == 0} {
   62         set starting 0
   63         continue
   64       } else {
   65         set ok 0
   66         set msg "Unexpected line '$line' at start"
   67         break
   68       }
   69     }
   70     # starting is now dealt with.
   71     if [regexp $re_geo $line dummy c] {
   72       if {! $in_cont} {
   73         set in_cont 1
   74         set continent $c
   75         set cont_dict [dict create]
   76         if {$continent in [dict keys $::mirrors]} {
   77           set ok 0
   78           set msg "Duplicate continent $c at line $lnum"
   79           break
   80         }
   81       } elseif {! $in_coun} {
   82         set in_coun 1
   83         set country $c
   84         if {$country in $countries} {
   85           set ok 0
   86           set msg "Duplicate country $c at line $lnum"
   87           break
   88         }
   89         lappend countries $country
   90         dict set cont_dict $country {}
   91       } else {
   92         set ok 0
   93         set msg "Unexpected continent- or country line $line at line $lnum"
   94         break
   95       }
   96     } elseif [regexp $re_url $line dummy u n] {
   97       if {! $in_coun} {
   98         set ok 0
   99         set msg "Unexpected url line $line at line $lnum"
  100         break
  101       } elseif {$n ne "1"} {
  102         continue
  103       }
  104       append u "systems/texlive/tlnet"
  105       if {$u in $urls} {
  106           set ok 0
  107           set msg "Duplicate url $u at line $lnum"
  108           break
  109       }
  110       dict lappend cont_dict $country $u
  111       lappend urls $u
  112       set u ""
  113     } elseif [regexp $re_clo $line] {
  114       if $in_coun {
  115         set in_coun 0
  116         set country ""
  117       } elseif $in_cont {
  118         set in_cont 0
  119         dict set ::mirrors $continent $cont_dict
  120         set continent ""
  121       } else {
  122         break ; # should close mirror list
  123       }
  124     } ; # ignore other lines
  125   }
  126   close $fm
  127 } ; # read_mirrors
  128 
  129 # cascading dropdown mirror menu
  130 # parameter cmd should be a proc which does something with the selected url
  131 proc mirror_menu {wnd cmd} {
  132   destroy $wnd.m
  133   if {[dict size $::mirrors] == 0} read_mirrors
  134   if {[dict size $::mirrors] > 0} {
  135     ttk::menubutton $wnd -text [__ "Specific mirror..."] \
  136         -direction below -menu $wnd.m
  137     menu $wnd.m
  138     dict for {cont d_cont} $::mirrors {
  139       set c_ed [mangle_name $cont]
  140       menu $wnd.m.$c_ed
  141       $wnd.m add cascade -label $cont -menu $wnd.m.$c_ed
  142       dict for {cntr urls} $d_cont {
  143         set n_ed [mangle_name $cntr]
  144         menu $wnd.m.$c_ed.$n_ed
  145         $wnd.m.$c_ed add cascade -label $cntr -menu $wnd.m.$c_ed.$n_ed
  146         foreach u $urls {
  147           $wnd.m.$c_ed.$n_ed add command -label $u -command "$cmd $u"
  148         }
  149       }
  150     }
  151   } else {
  152     ttk::label $wnd -text [__ "No mirror list available"]
  153   }
  154   return $wnd
  155 }
  156 
  157 proc possible_repository {s} {
  158   if [regexp {^(https?|ftp):\/\/.+} $s] {return 1}
  159   if {[string first {file://} $s] == 0} {set s [string range $s 7 end]}
  160   if [file isdirectory [file join $s "archive"]] {return 1}
  161   if [file isdirectory [file join $s "texmf-dist/web2c"]] {return 1}
  162   return 0
  163 }
  164 
  165 proc get_stacktrace {} {
  166   set level [info level]
  167   set s ""
  168   for {set i 1} {$i < $level} {incr i} {
  169     append s [format "Level %u: %s\n" $i [info level $i]]
  170   }
  171   return $s
  172 } ; # get_stacktrace
  173 
  174 proc normalize_argv {} {
  175   # work back to front, to not disturb indices of unscanned list elements
  176   set i $::argc
  177   while 1 {
  178     incr i -1
  179     if {$i<0} break
  180     set s [lindex $::argv $i]
  181     if {[string range $s 0 1] eq "--"} {
  182       set s [string range $s 1 end]
  183       #set ::argv [lreplace $::argv $i $i $s]
  184       lset ::argv $i $s
  185     }
  186     set j [string first "=" $s]
  187     if {$j > 0} {
  188       set s0 [string range $s 0 [expr {$j-1}]]
  189       set s1 [string range $s [expr {$j+1}] end]
  190       set ::argv [lreplace $::argv $i $i $s0 $s1]
  191     } elseif {$j==0} {
  192       err_exit "Command-line argument $s starting with \"=\""
  193     } ; # else leave alone
  194   }
  195   set ::argc [llength $::argv]
  196 }
  197 normalize_argv
  198 
  199 # localization support
  200 
  201 # for the sake of our translators we use our own translation function
  202 # which can use .po files directly. This allows them to check their work
  203 # without creating or waiting for a conversion to .msg.
  204 # We still use the msgcat module for detecting default locale.
  205 # Otherwise, the localization code borrows much from Norbert Preining's
  206 # translation module for TL.
  207 
  208 package require msgcat
  209 
  210 # available languages
  211 set ::langs [list "en"]
  212 foreach l [glob -nocomplain -directory \
  213                [file join $::instroot "tlpkg" "translations"] *.po] {
  214   lappend ::langs [string range [file tail $l] 0 end-3]
  215 }
  216 
  217 proc initialize_language {} {
  218   # check the command-line for a lang parameter
  219   set ::lang ""
  220   set i 0
  221   while {$i < $::argc} {
  222     set p [lindex $::argv $i]
  223     incr i
  224     if {$p eq "-lang" || $p eq "-gui-lang"} {
  225       if {$i < $::argc} {
  226         set ::lang [lindex $::argv $i]
  227         break
  228       }
  229     }
  230   }
  231   unset i
  232 
  233   # First fallback, only for tlshell: check tlmgr config file
  234   if {$::lang eq "" && [info exists ::invoker] && $::invoker eq "tlshell"} {
  235     set ::lang [get_config_var "gui-lang"]
  236   }
  237 
  238   # try to set tcltk's locale to $::lang too. this may not work for 8.5.
  239   if {$::lang ne ""} {::msgcat::mclocale $::lang}
  240 
  241   # second fallback: what does msgcat think about it? Note that
  242   # msgcat checks the environment and on windows also the registry.
  243   if {$::lang eq ""} {set ::lang [::msgcat::mclocale]}
  244 
  245   set messcat ""
  246   if {$::lang ne ""} {
  247     set messcat ""
  248     set maybe ""
  249     set ::lang [string tolower $::lang]
  250     set tdir [file join $::instroot "tlpkg" "translations"]
  251     foreach f [glob -nocomplain -directory $tdir *.po] {
  252       set ln_f [string tolower [string range [file tail $f] 0 end-3]]
  253       if {$ln_f eq $::lang} {
  254         set messcat $f
  255         break
  256       } elseif {[string range $ln_f 0 1] eq [string range $::lang 0 1]} {
  257         set maybe $f
  258       }
  259     }
  260     if {$messcat eq "" && $maybe ne ""} {
  261       set ::lang [string tolower [string range [file tail $maybe] 0 end-3]]
  262     }
  263   }
  264 }
  265 initialize_language
  266 
  267 proc load_translations {} {
  268   foreach s [array names ::TRANS] {
  269     array unset ::TRANS $s
  270   }
  271   if {$::lang eq ""} return
  272   set messcat [file join $::instroot "tlpkg" "translations" "${::lang}.po"]
  273   # parse messcat.
  274   # skip lines which make no sense
  275   if [file exists $messcat] {
  276     # create array with msgid keys and msgstr values
  277     # in the case that we switch languages,
  278     # we need to remove old translations,
  279     # since the new set may not completely cover the old one
  280     if {! [catch {open $messcat r} fid]} {
  281       fconfigure $fid -encoding utf-8
  282       set inmsgid 0
  283       set inmsgstr 0
  284       set msgid ""
  285       set msgstr ""
  286       while 1 {
  287         if [chan eof $fid] break
  288         if [catch {chan gets $fid} l] break
  289         if [regexp {^\s*#} $l] continue
  290         if [regexp {^\s*$} $l] {
  291           # empty line separates msgid/msgstr pairs
  292           if $inmsgid {
  293             # msgstr lines missing
  294             # puts stderr "no translation for $msgid in $messcat"
  295             set msgid ""
  296             set msgstr ""
  297             set inmsgid 0
  298             set inmsgstr 0
  299             continue
  300           }
  301           if $inmsgstr {
  302             # empty line signals end of msgstr
  303             if {$msgstr ne ""} {
  304               set msgid [string map {{\n} "\n"} $msgid]
  305               set msgstr [string map {{\n} "\n"} $msgstr]
  306               set msgid [string map {{\\} "\\"} $msgid]
  307               set msgstr [string map {{\\} "\\"} $msgstr]
  308               set msgid [string map {{\"} "\""} $msgid]
  309               set msgstr [string map {{\"} "\""} $msgstr]
  310               set ::TRANS($msgid) $msgstr
  311             }
  312             set msgid ""
  313             set msgstr ""
  314             set inmsgid 0
  315             set inmsgstr 0
  316             continue
  317           }
  318           continue
  319         } ; # empty line
  320         if [regexp {^msgid\s+"(.*)"\s*$} $l m msgid] {
  321           # note. a failed match will leave msgid alone
  322           set inmsgid 1
  323           continue
  324         }
  325         if [regexp {^"(.*)"\s*$} $l m s] {
  326           if $inmsgid {
  327             append msgid $s
  328           } elseif $inmsgstr {
  329             append msgstr $s
  330           }
  331           continue
  332         }
  333         if [regexp {^msgstr\s+"(.*)"\s*$} $l m msgstr] {
  334           set inmsgstr 1
  335           set inmsgid 0
  336         }
  337       }
  338       chan close $fid
  339     }
  340   }
  341 }
  342 load_translations
  343 
  344 proc __ {s args} {
  345   if {[info exists ::TRANS($s)]} {
  346     set s $::TRANS($s)
  347   #} else {
  348   #  puts stderr "No translation found for $s\n[get_stacktrace]"
  349   }
  350   if {$args eq ""} {
  351     return $s
  352   } else {
  353     return [format $s {*}$args]
  354   }
  355 }
  356 
  357 # string representation of booleans
  358 proc yes_no {b} {
  359   if $b {
  360     set ans [__ "Yes"]
  361   } else {
  362     set ans [__ "No"]
  363   }
  364   return $ans
  365 }
  366 
  367 # avoid warnings from tar and perl about locale
  368 set ::env(LC_ALL) "C"
  369 unset -nocomplain ::env(LANG)
  370 unset -nocomplain ::env(LANGUAGE)
  371 
  372 ### fonts ###
  373 
  374 # ttk defaults use TkDefaultFont and TkHeadingFont
  375 # ttk classic theme also uses TkTextFont for TEntry
  376 # ttk::combobox uses TkTextFont
  377 # although only the first three appear to be used here, this may depend
  378 # on the theme, so I resize all symbolic fonts anyway.
  379 
  380 set dflfonts [list \
  381   TkHeadingFont \
  382   TkCaptionFont \
  383   TkDefaultFont \
  384   TkMenuFont \
  385   TkTextFont \
  386   TkTooltipFont \
  387   TkFixedFont \
  388   TkIconFont \
  389   TkSmallCaptionFont \
  390 ]
  391 foreach f $::dflfonts {
  392   set ::oldsize($f) [font configure $f -size]
  393 }
  394 
  395 font create bfont
  396 font create lfont
  397 font create hfont
  398 font create titlefont
  399 
  400 proc redo_fonts {} {
  401 
  402   # note that ttk styles refer to the above symbolic font names
  403   # and generally do not define fonts themselves
  404 
  405   foreach f $::dflfonts {
  406     font configure $f -size [expr { round($::oldsize($f)*$::tkfontscale)}]
  407   }
  408   # the above works for ttk::*button, ttk::treeview, notebook labels
  409   unset -nocomplain f
  410 
  411   option add *font TkDefaultFont
  412   # the above works for menu items, ttk::label, text, ttk::entry
  413   # including current value of ttk::combobox, ttk::combobox list items
  414   # and non-ttk labels and buttons - which are not used here
  415   # apparently, these widget classes use the X11 default font on Linux.
  416 
  417   set ::cw \
  418     [expr {max([font measure TkDefaultFont "0"],[font measure TkTextFont "0"])}]
  419   # height: assume height == width*2
  420   # workaround for treeview on windows on HiDPI displays
  421   ttk::style configure Treeview -rowheight [expr {3 * $::cw}]
  422 
  423   # no bold text for messages; `userDefault' indicates priority
  424   option add *Dialog.msg.font TkDefaultFont userDefault
  425 
  426   # normal size bold
  427   font configure bfont {*}[font configure TkDefaultFont]
  428   font configure bfont -weight bold
  429   # larger, not bold: lfont
  430   font configure lfont {*}[font configure TkDefaultFont]
  431   font configure lfont -size [expr {round(1.2 * [font actual lfont -size])}]
  432   # larger and bold
  433   font configure hfont {*}[font configure lfont]
  434   font configure hfont -weight bold
  435   # extra large and bold
  436   font configure titlefont {*}[font configure TkDefaultFont]
  437   font configure titlefont -weight bold \
  438       -size [expr {round(1.5 * [font actual titlefont -size])}]
  439 }
  440 
  441 # initialize scaling factor
  442 
  443 set ::tkfontscale ""
  444 if {[info exists ::invoker] && $::invoker eq "tlshell"} {
  445   set ::tkfontscale [get_config_var "tkfontscale"]
  446   # is $::tkfontscale a number, and a reasonable one?
  447   if {[scan $::tkfontscale {%f} f] != 1} { ; # not a number
  448     set ::tkfontscale ""
  449   } elseif {$::tkfontscale < 0} {
  450     set ::tkfontscale ""
  451   } elseif {$::tkfontscale < 0.5} {
  452     set ::tkfontscale 0.5
  453   } elseif {$::tkfontscale > 10} {
  454     set ::tkfontscale 10
  455   }
  456 }
  457 if {$::tkfontscale eq ""} {
  458   if {[winfo vrootheight .] > 2000 && [winfo vrootwidth .] > 3000} {
  459     set ::tkfontscale 2
  460   } else {
  461     set ::tkfontscale 1
  462   }
  463 }
  464 redo_fonts
  465 
  466 # icon
  467 catch {
  468   image create photo tl_logo -file \
  469       [file join $::instroot "tlpkg" "tltcl" "tlmgr.gif"]
  470   wm iconphoto . -default tl_logo
  471 }
  472 
  473 # default foreground color and disabled foreground color
  474 # may not be black in e.g. dark color schemes
  475 set blk [ttk::style lookup TButton -foreground]
  476 set gry [ttk::style lookup TButton -foreground disabled]
  477 
  478 # 'default' padding
  479 
  480 proc ppack {wdg args} { ; # pack command with padding
  481   pack $wdg {*}$args -padx 3 -pady 3
  482 }
  483 
  484 proc pgrid {wdg args} { ; # grid command with padding
  485   grid $wdg {*}$args -padx 3 -pady 3
  486 }
  487 
  488 # unicode symbols as fake checkboxes in ttk::treeview widgets
  489 
  490 proc mark_sym {mrk} {
  491   if {$::tcl_platform(platform) eq "windows"} {
  492     # under windows, these look slightly better than
  493     # the non-windows selections
  494     if $mrk {
  495       return "\u2714" ; # 'heavy check mark'
  496     } else {
  497       return "\u25CB" ; # 'white circle'
  498     }
  499   } else {
  500     if $mrk {
  501       return "\u25A3" ; # 'white square containing black small square'
  502     } else {
  503       return "\u25A1" ; # 'white square'
  504     }
  505   }
  506 } ; # mark_sym
  507 
  508 # for help output
  509 set ::env(NOPERLDOC) 1
  510 
  511 ##### dialog support #####
  512 
  513 # for example code, look at dialog.tcl, part of Tk itself
  514 
  515 # In most cases, it is not necessary to explicitly define a handler for
  516 # the WM_DELETE_WINDOW protocol. But if the cancel- or abort button would do
  517 # anything special, then the close icon should not bypass this.
  518 
  519 # widget classes which can be enabled and disabled.
  520 # The text widget class is not included here.
  521 
  522 set ::active_cls [list TButton TCheckbutton TRadiobutton TEntry Treeview]
  523 
  524 # global variable for dialog return value, in case the outcome
  525 # must be handled by the caller rather than by the dialog itself:
  526 set ::dialog_ans {}
  527 
  528 # start new toplevel with settings appropriate for a dialog
  529 proc create_dlg {wnd {p .}} {
  530   unset -nocomplain ::dialog_ans
  531   catch {destroy $wnd} ; # no error if it does not exist
  532   toplevel $wnd -class Dialog
  533   wm withdraw $wnd
  534   if [winfo viewable $p] {wm transient $wnd $p}
  535   if $::plain_unix {wm attributes $wnd -type dialog}
  536 }
  537 
  538 # Place a dialog centered wrt its parent.
  539 # If its geometry is somehow not yet available,
  540 # its upperleft corner will be centered.
  541 
  542 proc place_dlg {wnd {p "."}} {
  543   update idletasks
  544   set g [wm geometry $p]
  545   scan $g "%dx%d+%d+%d" pw ph px py
  546   set hcenter [expr {$px + $pw / 2}]
  547   set vcenter [expr {$py + $ph / 2}]
  548   set g [wm geometry $wnd]
  549   set wh [winfo reqheight $wnd]
  550   set ww [winfo reqwidth $wnd]
  551   set wx [expr {$hcenter - $ww / 2}]
  552   if {$wx < 0} { set wx 0}
  553   set wy [expr {$vcenter - $wh / 2}]
  554   if {$wy < 0} { set wy 0}
  555   wm geometry $wnd [format "+%d+%d" $wx $wy]
  556   update idletasks
  557   wm state $wnd normal
  558   raise $wnd $p
  559   tkwait visibility $wnd
  560   focus $wnd
  561   grab set $wnd
  562 } ; # place_dlg
  563 
  564 # in case pressing the closing button leads to lengthy processing:
  565 proc disable_dlg {wnd} {
  566   foreach c [winfo children $wnd] {
  567     if {[winfo class $c] in $::active_cls} {
  568       catch {$c state disabled}
  569     }
  570   }
  571 }
  572 
  573 proc end_dlg {ans wnd} {
  574   set ::dialog_ans $ans
  575   set p [winfo parent $wnd]
  576   if {$p eq ""} {set p "."}
  577   raise $p
  578   destroy $wnd
  579 } ; # end_dlg
  580 
  581 # a possibly useful callback for WM_DELETE_WINDOW
  582 proc cancel_or_destroy {ctrl topl} {
  583   if [winfo exists $ctrl] {
  584     $ctrl invoke
  585   } elseif [winfo exists $topl] {
  586     destroy $topl
  587   }
  588 }
  589 
  590 ##### directories #####
  591 
  592 # slash flipping
  593 proc forward_slashify {s} {
  594   regsub -all {\\} $s {/} r
  595   return $r
  596 }
  597 proc native_slashify {s} {
  598   if {$::tcl_platform(platform) eq "windows"} {
  599     regsub -all {/} $s {\\} r
  600   } else {
  601     regsub -all {\\} $s {/} r
  602   }
  603   return $r
  604 }
  605 
  606 # test whether a directory is writable.
  607 # 'file writable' merely tests permissions, which may not be good enough
  608 proc dir_writable {d} {
  609   for {set x 0} {$x<100} {incr x} {
  610     set y [expr {int(10000*rand())}]
  611     set newfile [file join $d $y]
  612     if [file exists $newfile] {
  613       continue
  614     } else {
  615       if [catch {open $newfile w} fid] {
  616         return 0
  617       } else {
  618         chan puts $fid "hello"
  619         chan close $fid
  620         if [file exists $newfile] {
  621           file delete $newfile
  622           return 1
  623         } else {
  624           return 0
  625         }
  626       }
  627     }
  628   }
  629   return 0
  630 }
  631 
  632 # unix: choose_dir replacing native directory browser
  633 
  634 if {$::tcl_platform(platform) eq "unix"} {
  635 
  636   # Based on the directory browser from the tcl/tk widget demo.
  637   # Also for MacOS, because we want to see /usr.
  638   # For windows, the native browser widget is better.
  639 
  640   ## Code to populate a single directory node
  641   proc populateTree {tree node} {
  642     if {[$tree set $node type] ne "directory"} {
  643       set type [$tree set $node type]
  644       return
  645     }
  646     $tree delete [$tree children $node]
  647     foreach f [lsort [glob -nocomplain -directory $node *]] {
  648       set type [file type $f]
  649       if {$type eq "directory"} {
  650         $tree insert $node end \
  651             -id $f -text [file tail $f] -values [list $type]
  652         # Need at least one child to make this node openable,
  653         # will be deleted when actually populating this node
  654         $tree insert $f 0 -text "dummy"
  655       }
  656     }
  657     # Stop this code from rerunning on the current node
  658     $tree set $node type processedDirectory
  659   }
  660 
  661   proc choose_dir {initdir {parent .}} {
  662 
  663     create_dlg .browser $parent
  664     wm title .browser [__ "Browse..."]
  665 
  666     # wallpaper
  667     pack [ttk::frame .browser.bg -padding 3] -fill both -expand 1
  668 
  669     # ok and cancel buttons
  670     pack [ttk::frame .browser.fr1] \
  671         -in .browser.bg -side bottom -fill x
  672     ppack [ttk::button .browser.ok -text [__ "Ok"]] \
  673         -in .browser.fr1 -side right
  674     ppack [ttk::button .browser.cancel -text [__ "Cancel"]] \
  675         -in .browser.fr1 -side right
  676     bind .browser <Escape> {.browser.cancel invoke}
  677     wm protocol .browser WM_DELETE_WINDOW \
  678         {cancel_or_destroy .browser.cancel .browser}
  679     .browser.ok configure -command {
  680       set ::dialog_ans [.browser.tree focus]
  681       destroy .browser
  682     }
  683     .browser.cancel configure -command {
  684       set ::dialog_ans ""
  685       destroy .browser
  686     }
  687 
  688     ## Create the tree and set it up
  689     pack [ttk::frame .browser.fr0] -in .browser.bg -fill both -expand 1
  690     set tree [ttk::treeview .browser.tree \
  691                   -columns {type} -displaycolumns {} -selectmode browse \
  692                   -yscroll ".browser.vsb set"]
  693     .browser.tree column 0 -stretch 1
  694     ttk::scrollbar .browser.vsb -orient vertical -command "$tree yview"
  695     # hor. scrolling does not work, but toplevel and widget are resizable
  696     $tree heading \#0 -text "/"
  697     $tree insert {} end -id "/" -text "/" -values [list "directory"]
  698 
  699     populateTree $tree "/"
  700     bind $tree <<TreeviewOpen>> {
  701       populateTree %W [%W focus]
  702     }
  703     bind $tree <ButtonRelease-1> {
  704       .browser.tree heading \#0 -text [%W focus]
  705     }
  706 
  707     ## Arrange the tree and its scrollbar in the toplevel
  708     # Horizontal scrolling does not work, but resizing does.
  709     grid $tree -in .browser.fr0 -row 0 -column 0 -sticky nsew
  710     grid .browser.vsb -in .browser.fr0 -row 0 -column 1 -sticky ns
  711     grid columnconfigure .browser.fr0 0 -weight 1
  712     grid rowconfigure .browser.fr0 0 -weight 1
  713     unset -nocomplain ::dialog_ans
  714 
  715     # navigate tree to $initdir
  716     set chosenDir {}
  717     foreach d [file split [file normalize $initdir]] {
  718       set nextdir [file join $chosenDir $d]
  719       if [file isdirectory $nextdir] {
  720         if {! [$tree exists $nextdir]} {
  721           $tree insert $chosenDir end -id $nextdir \
  722               -text $d -values [list "directory"]
  723         }
  724         populateTree $tree $nextdir
  725         set chosenDir $nextdir
  726       } else {
  727         break
  728       }
  729     }
  730     $tree see $chosenDir
  731     $tree selection set [list $chosenDir]
  732     $tree focus $chosenDir
  733     $tree heading \#0 -text $chosenDir
  734 
  735     place_dlg .browser $parent
  736     tkwait window .browser
  737     return $::dialog_ans
  738   }; # choose_dir
  739 
  740 }; # if unix
  741 
  742 proc browse4dir {inidir {parent .}} {
  743   if {$::tcl_platform(platform) eq "unix"} {
  744     return [choose_dir $inidir $parent]
  745   } else {
  746     return [tk_chooseDirectory \
  747         -initialdir $inidir -title [__ "Select or type"] -parent $parent]
  748   }
  749 } ; # browse4dir
  750 
  751 # browse for a directory and store in entry- or label widget $w
  752 proc dirbrowser2widget {w} {
  753   set wclass [winfo class $w]
  754   if {$wclass eq "Entry" || $wclass eq "TEntry"} {
  755     set is_entry 1
  756   } elseif {$wclass eq "Label" || $wclass eq "TLabel"} {
  757     set is_entry 0
  758   } else {
  759     err_exit "browse2widget invoked with unsupported widget class $wclass"
  760   }
  761   if $is_entry {
  762     set retval [$w get]
  763   } else {
  764     set retval [$w cget -text]
  765   }
  766   set retval [browse4dir $retval [winfo parent $w]]
  767   if {$retval eq ""} {
  768     return 0
  769   } else {
  770     if {$wclass eq "Entry" || $wclass eq "TEntry"} {
  771       $w delete 0 end
  772       $w insert 0 $retval
  773     } else {
  774       $w configure -text $retval
  775     }
  776     return 1
  777   }
  778 }